├── .gitignore
├── README.md
├── dune-project
├── lib
├── dune
└── podge.ml
├── podge.opam
└── podge_listing.gif
/.gitignore:
--------------------------------------------------------------------------------
1 | _build/
2 | *.install
3 | *.merlin
4 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | **Podge** is a centralization of helper functions and shortcuts that I
2 | have frequently found myself writing over and over again in [OCaml](http://www.ocaml.org). It
3 | doesn't depend on Jane Street's [Core](https://github.com/janestreet/core), [Batteries](https://github.com/ocaml-batteries-team/batteries-included) or even [Lwt](http://ocsigen.org/lwt/). Rather
4 | Podge picks among various existing smaller packages that you probably
5 | already have installed and provides helper functions for common tasks
6 | related to usages of those libraries. Podge also provides some extra
7 | modules like the Math module.
8 |
9 | **Podge** is well suited for hackathons, especially when you just want
10 | to do a quick HTTP get request for JSON data and subsequently play
11 | with the JSON.
12 |
13 | See simple documentation [online](http://hyegar.com/podge/)
14 |
15 | # Examples
16 |
17 | You can install with
18 | ```shell
19 | $ opam install podge
20 | ```
21 | And use it in your projects with the `podge` opam package,
22 |
23 | ```shell
24 | $ ocamlfind ocaml{opt,c} -package podge code.ml -o Example_program
25 | ```
26 |
27 | ## Requests
28 |
29 | Simple HTTP only requests will work, HTTPs will be added later but you
30 | can still try HTTPS based requests.
31 |
32 | ```ocaml
33 | let () =
34 | match Podge.Web.get "http://hyegar.com" with
35 | | Ok (status_line, headers, body) ->
36 | Printf.printf "Status_line: %s\n" status_line;
37 | print_endline body
38 | | Error _ ->
39 | print_endline "Error"
40 | ```
41 |
42 | ## Xml
43 |
44 | Program for querying XML documents
45 |
46 | ```html
47 |
48 | Some innards
49 | A Long article ...
50 |
51 | ```
52 |
53 | Podge Code
54 |
55 | ```ocaml
56 | (* This file is named show_node.ml *)
57 | #require "podge"
58 |
59 | let () =
60 | Podge.Xml.query_node_of_file ["outer";"Article"] Sys.argv.(1)
61 | |> print_endline
62 | ```
63 |
64 | Result
65 |
66 | ```shell
67 | $ utop show_node.ml doc.html
68 | A Long article ...
69 | ```
70 |
71 | # Overview of Modules
72 |
73 | Everything is contained under one module, the `Podge` module. Modules
74 | that contain helpers for existing OCaml packages will have the same
75 | name as the package, for example `Podge.Yojson` contains functions for
76 | working with the `yojson` package. While `Podge.Math` contains various
77 | mathematical and statistical functions.
78 |
79 | Probably the easiest way to learn what's provided by Podge is to look
80 | at it via `ocp-browser`, provided by the [ocp-index](https://github.com/OCamlPro/ocp-index) package, have
81 | `lambda-term` installed before you install `ocp-index` so that
82 | `ocp-browser` is installed.
83 |
84 | 
85 |
86 | Hopefully the functions are named in such a way that you can infer the
87 | semantics/intended usage.
88 |
89 | # Yet another Standard Library Replacement?
90 |
91 | No, this isn't yet another attempt at a standard library
92 | replacement. Rather this is one place for me to put all code that I've
93 | had scattered all around my hard-drive ranging from stuff that I've
94 | written, to useful StackOverflow answers, to IRC chats, general
95 | googling and Computer Science courses.
96 |
97 | I focus on functionality, not new data structures or improvements of the
98 | StdLib provided data structures, functions.
99 |
100 | Perhaps there will be something of use in here as well for you. I
101 | hope that some things here will help newcomers to the language as
102 | well or at least help with quick Python like prototyping.
103 |
--------------------------------------------------------------------------------
/dune-project:
--------------------------------------------------------------------------------
1 | (lang dune 1.11)
2 | (name podge)
3 | (explicit_js_mode)
4 |
--------------------------------------------------------------------------------
/lib/dune:
--------------------------------------------------------------------------------
1 | (library
2 | (name podge)
3 | (public_name podge)
4 | (modules podge)
5 | (wrapped false)
6 | (libraries yojson cohttp tyxml unix re.pcre ezxmlm ANSITerminal astring))
7 |
--------------------------------------------------------------------------------
/lib/podge.ml:
--------------------------------------------------------------------------------
1 | (** A Hodgepodge of functionality in OCaml *)
2 |
3 | (** Module handles to the original libraries themselves *)
4 | module Originals = struct
5 | module U = Unix
6 | module P = Printf
7 | module L = List
8 | module Y = Yojson.Basic
9 | module T = ANSITerminal
10 | module S = String
11 | end
12 |
13 | (** Simple Module Alias of Astring *)
14 | module String = Astring
15 |
16 | (** Math and Probability functions *)
17 | module Math = struct
18 |
19 | type 'a nums = Int : int nums | Float : float nums
20 |
21 | (** Produce an array of random Floats or Ints *)
22 | let random_array =
23 | fun (type t) n (num_t : t nums) ->
24 | Random.self_init ();
25 | match num_t with
26 | | Int ->
27 | (Array.init n (fun _ ->
28 | let made = Random.int (1 lsl 30 - 1) in
29 | if Random.bool () then made else -1 * made) : t array)
30 | | Float ->
31 | (Array.init n (fun _ -> Random.float max_float) : t array)
32 |
33 | (** Calculate first deriviative of f *)
34 | let derivative ~f argument =
35 | let eps = sqrt epsilon_float in
36 | ((f (argument +. eps)) -. (f (argument -. eps))) /. (2. *. eps)
37 |
38 | (** Simple Linear regression *)
39 | let linear_regression ~xs ~ys =
40 | let sum xs = Array.fold_right (fun value running -> value +. running) xs 0.0 in
41 | let mean xs = (sum xs) /. (float_of_int (Array.length xs)) in
42 | let mean_x = mean xs in
43 | let mean_y = mean ys in
44 | let std xs m =
45 | let normalizer = (Array.length xs) - 1 in
46 | sqrt ((Array.fold_right begin fun value running ->
47 | ((value -. m) ** 2.0) +. running
48 | end
49 | xs 0.0) /.
50 | (float_of_int normalizer)) in
51 | let pearson_r xs ys =
52 | let sum_xy = ref 0.0 in
53 | let sum_sq_v_x = ref 0.0 in
54 | let sum_sq_v_y = ref 0.0 in
55 | let zipped = Originals.L.combine (Array.to_list xs) (Array.to_list ys) in
56 | List.iter begin fun (i_x, i_y) ->
57 | let var_x = i_x -. mean_x in
58 | let var_y = i_y -. mean_y in
59 | sum_xy := !sum_xy +. (var_x *. var_y);
60 | sum_sq_v_x := !sum_sq_v_x +. (var_x ** 2.0);
61 | sum_sq_v_y := !sum_sq_v_y +. (var_y ** 2.0)
62 | end
63 | zipped;
64 | !sum_xy /. (sqrt (!sum_sq_v_x *. !sum_sq_v_y)) in
65 | let r = pearson_r xs ys in
66 | let b = r *. (std ys mean_y) /. (std xs mean_x) in
67 | let a = mean_y -. b *. mean_x in
68 | let line x =
69 | b *. x +. a in
70 | line
71 |
72 | let rec pow ~base = function
73 | | 0 -> 1
74 | | 1 -> base
75 | | n ->
76 | let b = pow ~base:base (n / 2) in
77 | b * b * (if n mod 2 = 0 then 1 else base)
78 |
79 | let log2 x = (log x ) /. (log 2.)
80 |
81 | let bit_string_of_int num =
82 | let rec helper a_num accum = match a_num with
83 | | 0 -> accum
84 | | _x -> string_of_int (a_num mod 2) :: helper (a_num / 2) accum
85 | in
86 | helper num [] |> List.rev |> Originals.S.concat ""
87 |
88 | let bit_string_of_string str =
89 | let all_ints = ref [] in
90 | Originals.S.iter
91 | (fun a_char -> all_ints := (int_of_char a_char) :: !all_ints)
92 | str;
93 | List.rev !all_ints |> List.map bit_string_of_int |> Originals.S.concat ""
94 |
95 | let sum_ints l =
96 | List.fold_left ( + ) 0 l
97 |
98 | let sum_floats l =
99 | List.fold_left ( +. ) 0.0 l
100 |
101 | let average_ints l =
102 | float_of_int (sum_ints l) /. float_of_int (List.length l)
103 |
104 | let average_floats l =
105 | sum_floats l /. float_of_int (List.length l)
106 |
107 | let pi = 4.0 *. atan 1.0
108 |
109 | (** Range takes:
110 | an optional chunk int [defaulting to 1],
111 | an optional inclusivity bool [defaulting to false],
112 | a labeled ~from int [where the list starts from]
113 | and finally, the "upto" int [where the list ends].
114 |
115 | By default, your upto is not inclusive. So for example:
116 | 1 <--> 5 gives back [1; 2; 3; 4]
117 | but
118 | 1 <---> 5 gives back [1; 2; 3; 4; 5]
119 |
120 | It can also handle descending amounts:
121 | 1 <---> -10 gives you
122 | [1; 0; -1; -2; -3; -4; -5; -6; -7; -8; -9; -10]
123 | and 1 <--> 1 gives you []
124 |
125 | Note: <--> <---> are located in Podge.Infix
126 | See also: it is tail recursive. *)
127 | let range ?(chunk=1) ?(inclusive=false) ~from upto =
128 | if (upto < from)
129 | then begin
130 | let rec dec_aux count upto accum =
131 | if inclusive
132 | then begin
133 | if (count - chunk) < upto
134 | then List.rev (count::accum)
135 | else dec_aux (count - chunk) upto (count::accum)
136 | end
137 | else begin
138 | if (count - chunk) <= upto
139 | then List.rev (count::accum)
140 | else dec_aux (count - chunk) upto (count::accum)
141 | end
142 | in
143 | dec_aux from upto []
144 | end
145 | else if upto = from then []
146 | else begin
147 | let rec asc_aux count upto accum =
148 | if inclusive then begin
149 | if (count + chunk) > upto
150 | then List.rev (count::accum)
151 | else asc_aux (count + chunk) upto (count::accum)
152 | end else begin
153 | if (count + chunk) >= upto
154 | then List.rev (count::accum)
155 | else asc_aux (count + chunk) upto (count::accum)
156 | end
157 | in
158 | asc_aux from upto []
159 | end
160 |
161 | let validate_prob p =
162 | if p < 0.0 || p > 1.0
163 | then raise (Invalid_argument "Not a valid Probability, \
164 | needs to be between 0 and 1")
165 |
166 | (** Computes the entropy from a list of probabilities *)
167 | let entropy probs =
168 | List.fold_left begin fun accum p ->
169 | validate_prob p;
170 | accum +. (p *. log2 (1.0 /. p))
171 | end
172 | 0.0
173 | probs
174 |
175 | (** Represents the number of bits of information contained in this
176 | message, roughly how many number of bits we should encode this
177 | message with. The less likely an event is to occur, the more
178 | information we can say actually is contained in the event *)
179 | let self_information p =
180 | validate_prob p;
181 | log2 (1.0 /. p)
182 |
183 | let rec distance l r = match l, r with
184 | | a_val_l :: rest_l, a_val_r :: rest_r ->
185 | (a_val_l -. a_val_r) ** 2.0 +. distance rest_l rest_r
186 | | _ -> 0.0
187 |
188 | let init_with_f ~f n =
189 | let rec init_aux n accum =
190 | if n <= 0 then accum else init_aux (n - 1) (f (n - 1) :: accum)
191 | in
192 | init_aux n []
193 |
194 | let combination n m =
195 | let g (k, r) = init_with_f ~f:(fun i -> k + pow ~base:2 (n - i - 1), i) r in
196 | let rec aux m xs =
197 | if m = 1 then List.map fst xs
198 | else aux (m - 1) (List.map g xs |> List.concat)
199 | in
200 | aux m (init_with_f ~f:(fun i -> pow ~base:2 i, n - i - 1) n)
201 |
202 | end
203 |
204 | module Infix = struct
205 |
206 | (** See Podge.Math.range for documentation. *)
207 | let (<-->) i j = Math.range ~from:i j
208 |
209 | (** See Podge.Math.range for documentation. *)
210 | let (<--->) i j = Math.range ~inclusive:true ~from:i j
211 | end
212 |
213 | (** Pretty printing of json and updating *)
214 | module Yojson = struct
215 |
216 | type did_update = [`Updated | `No_update]
217 |
218 | let show_pretty_of_string s =
219 | Yojson.Basic.from_string s
220 | |> Yojson.Basic.pretty_to_string
221 | |> print_endline
222 |
223 | let show_pretty_of_in_mem j =
224 | Yojson.Basic.pretty_to_string j |> print_endline
225 |
226 | let show_pretty_of_file f =
227 | Yojson.Basic.from_file f
228 | |> Yojson.Basic.pretty_to_string
229 | |> print_endline
230 |
231 | (** Update a value for a given key *)
232 | let update ~key ~new_value j : (did_update * Yojson.Basic.t) =
233 | let updated = ref false in
234 | let as_obj = Yojson.Basic.Util.to_assoc j in
235 | let g = List.map begin function
236 | | (this_key, _inner) when this_key = key -> updated := true; (this_key, new_value)
237 | | otherwise -> otherwise
238 | end
239 | as_obj
240 | in
241 | if !updated then (`Updated, `Assoc g) else (`No_update, `Assoc g)
242 |
243 | (** Remove a key-value pair *)
244 | let remove ~key j : (did_update * Yojson.Basic.t) =
245 | let updated = ref false in
246 | let as_obj = Yojson.Basic.Util.to_assoc j in
247 | let g = List.fold_left begin fun accum ((this_key, _) as key_value) ->
248 | if this_key = key then (updated := true; accum) else key_value :: accum
249 | end
250 | []
251 | as_obj
252 | in
253 | if !updated then (`Updated, `Assoc (List.rev g))
254 | else (`No_update, `Assoc (List.rev g))
255 |
256 | end
257 |
258 | (** Helper functions for using Tyxml *)
259 | module Html5 = struct
260 |
261 | (** Print to stdout a tag *)
262 | let show_tag e =
263 | let format =
264 | Format.formatter_of_out_channel Stdlib.stdout
265 | in
266 | Tyxml.Xml.pp () format e
267 |
268 | (** Convert a Tyxml into a string *)
269 | let to_string e =
270 | let cont = Buffer.create 1024 in
271 | let format =
272 | Format.formatter_of_buffer cont
273 | in
274 | Tyxml.Xml.pp () format e;
275 | Buffer.contents cont
276 |
277 | end
278 |
279 | module Unix : sig
280 |
281 | (** Read all the output of a process *)
282 | val read_process_output : string -> string list
283 |
284 | (** Read all the contents of a file, get back a string *)
285 | val read_lines : string -> string list
286 |
287 | (** Read all the contents of a file as a single string *)
288 | val read_all : string -> string
289 |
290 | (** Read one char from the terminal without waiting for the return
291 | key *)
292 | val get_one_char : unit -> char
293 |
294 | (** Simple time stamp of the current time *)
295 | val time_now : unit -> string
296 |
297 | (** Daemonize the current process *)
298 | val daemonize : unit -> unit
299 |
300 | (** Simple timeout *)
301 | val timeout:
302 | ?on_timeout:(unit -> unit) ->
303 | arg:'a ->
304 | timeout:int ->
305 | default_value:'b -> ('a -> 'b) -> 'b
306 |
307 | end = struct
308 |
309 | let exhaust ic =
310 | let all_input = ref [] in
311 | (try while true do all_input := input_line ic :: !all_input; done
312 | with End_of_file -> ());
313 | close_in ic;
314 | List.rev !all_input
315 |
316 | let read_process_output p = Unix.open_process_in p |> exhaust
317 |
318 | let read_lines path = open_in path |> exhaust
319 |
320 | let read_all path = open_in path |> exhaust |> Originals.S.concat ""
321 |
322 | let get_one_char () =
323 | let termio = Unix.(tcgetattr stdin) in
324 | Unix.(tcsetattr stdin TCSADRAIN { termio with c_icanon = false });
325 | let res = input_char stdin in
326 | Unix.(tcsetattr stdin TCSADRAIN termio);
327 | res
328 |
329 | let time_now () = Unix.(
330 | let localtime = localtime (time ()) in
331 | Printf.sprintf
332 | "[%02u:%02u:%02u]" localtime.tm_hour localtime.tm_min localtime.tm_sec
333 | )
334 |
335 | let daemonize () = match Unix.fork () with
336 | | pid ->
337 | if pid < 0 then raise (Failure "Couldn't fork correctly")
338 | else if pid > 0 then exit (-1)
339 | else begin match Unix.setsid () with
340 | | sid ->
341 | if sid < 0 then raise (Failure "Issue with setsid")
342 | else if sid > 0 then exit (-1)
343 | else begin
344 | Unix.umask 0 |> fun _ ->
345 | Unix.chdir "/"; List.iter Unix.close [Unix.stdin; Unix.stdout]
346 | end
347 | end
348 |
349 | let timeout ?(on_timeout = fun () -> ()) ~arg ~timeout ~default_value f =
350 | let exception Timeout in
351 | let sigalrm_handler = Sys.Signal_handle (fun _ -> raise Timeout) in
352 | let old_behavior = Sys.signal Sys.sigalrm sigalrm_handler in
353 | let reset_sigalrm () = Sys.set_signal Sys.sigalrm old_behavior in
354 | ignore (Unix.alarm timeout);
355 | try
356 | let res = f arg in
357 | reset_sigalrm ();
358 | res
359 | with exc ->
360 | reset_sigalrm ();
361 | if exc = Timeout
362 | then (on_timeout (); default_value)
363 | else raise exc
364 |
365 | end
366 |
367 | module Analyze = struct
368 |
369 | let time_it ~f x =
370 | let t = Sys.time() in
371 | let fx = f x in
372 | (Printf.sprintf "Execution time: %fs\n" (Sys.time() -. t), fx)
373 |
374 | (* TODO Add a doc string explaing meaning *)
375 | let ratio_pair time_double time =
376 | let r = time_double /. time in
377 | (`Time_ratio r, `Time_log2_ratio (Math.log2 r))
378 |
379 | end
380 |
381 | module Cohttp = struct
382 |
383 | let did_request_succeed resp =
384 | Cohttp.Response.status resp
385 | |> Cohttp.Code.code_of_status
386 | |> Cohttp.Code.is_success
387 |
388 | let show_headers hdrs =
389 | hdrs |> Cohttp.Header.iter begin fun key values ->
390 | Printf.sprintf "%s" (Printf.sprintf "%s %s" key (Originals.S.concat "" values))
391 | |> print_endline
392 | end
393 | end
394 |
395 | module Printf = struct
396 |
397 | let printfn str = Printf.kprintf print_endline str
398 | let printfn_e str = Printf.kprintf prerr_endline str
399 |
400 | end
401 |
402 | module Debugging = struct
403 |
404 | let show_callstack n =
405 | Printexc.get_callstack n
406 | |> Printexc.raw_backtrace_to_string
407 | |> print_endline
408 |
409 | end
410 |
411 | module List = struct
412 |
413 | (** Evaluate f on each item of the given list and check if all
414 | evaluated to true *)
415 | let all ~f on =
416 | List.map f on |> List.fold_left (&&) true
417 |
418 | (** Evaluate f on each item of the given list and check if any
419 | evaluated to false *)
420 | let any ~f on =
421 | List.map f on |> List.fold_left (||) false
422 |
423 | let unique l =
424 | List.fold_left (fun a e -> if List.mem e a then a else e :: a) [] l
425 |
426 | let group_by ls =
427 | let ls' = List.fold_left begin fun accum (this_key, x1) ->
428 | match accum with
429 | | [] -> [(this_key, [x1])]
430 | | (that_key, ls2) :: acctl ->
431 | if this_key = that_key then (this_key, x1 :: ls2) :: acctl
432 | else (this_key, [x1]) :: accum
433 | end
434 | []
435 | ls
436 | in
437 | List.rev ls'
438 |
439 | let take ~n xs =
440 | let rec aux n xs accum =
441 | if n <= 0 || xs = [] then List.rev accum
442 | else aux (n - 1) (List.tl xs) (List.hd xs :: accum)
443 | in
444 | aux n xs []
445 |
446 | let rec drop ~n xs =
447 | if n <= 0 || xs = [] then xs
448 | else drop ~n:(n - 1) (List.tl xs)
449 |
450 | let equal_parts ~segs l =
451 | let this_much = (List.length l) / segs in
452 | let rec helper accum rest = match rest with
453 | | [] -> accum
454 | | rest ->
455 | let pull = take ~n:this_much rest in
456 | let remaining = drop ~n:this_much rest in
457 | if List.length remaining < this_much
458 | then (remaining @ pull) :: helper accum []
459 | else pull :: helper accum remaining
460 | in
461 | helper [] l
462 |
463 | let filter_map ~f ~g l =
464 | List.fold_left begin fun accum value ->
465 | if f value then g value :: accum else accum end
466 | [] l
467 |
468 | let cut l start =
469 | let result = List.fold_right begin fun value (counter, (pre, after)) ->
470 | if counter <> start then (counter + 1, (value :: pre, after))
471 | else (counter, (pre, value :: after))
472 | end
473 | (List.rev l)
474 | (0, ([], []))
475 | in
476 | let (pre, after) = snd result in
477 | (List.rev pre, List.rev after)
478 |
479 | end
480 |
481 | module Web : sig
482 |
483 | (** Various reason why a HTTP request might fail *)
484 | type error_t =
485 | Can_only_handle_http | Host_lookup_failed | No_ip_from_hostname
486 | | Post_failed
487 |
488 | (** Goes: HTTP status line, HTTP Headers, response body *)
489 | type reply = (string * string list * string, error_t) result
490 |
491 | (** Takes a HTTP url and gives back an optional pair of a list of
492 | headers and the body. HTTPS is accepted but warning it is not
493 | implemented so HTTPS servers may reject your request *)
494 | val get: ?trim_body:bool -> string -> reply
495 |
496 | (** Takes a route and a bytes for body and does a PUT, no checking
497 | of HTTP errors, like get HTTPS requests will be accepted by
498 | post but it may be rejected by an HTTPS server since HTTPS is
499 | not currently implemented.*)
500 | val post : ?trim_reply:bool -> ?post_body:string -> string -> reply
501 |
502 | end = struct
503 |
504 | type error_t =
505 | Can_only_handle_http | Host_lookup_failed | No_ip_from_hostname
506 | | Post_failed
507 |
508 | type reply = (string * string list * string, error_t) result
509 |
510 | let (>>=) x (f: 'a -> 'b option) = match x with None -> None | Some d -> (f d)
511 |
512 | let address host =
513 | Originals.U.(ADDR_INET ((gethostbyname host).h_addr_list.(0), 80))
514 |
515 | let really_output out_chan message =
516 | output_bytes out_chan message; flush out_chan
517 |
518 | let read_all in_chan =
519 | let buff = Buffer.create 4096 in
520 | (try while true do input_char in_chan |> Buffer.add_char buff done
521 | with End_of_file -> ());
522 | buff |> Buffer.to_bytes
523 |
524 | let headers_and_body ?(trim_body=true) http_resp =
525 | let starting_point = ref 2 in
526 | let end_len = Bytes.length http_resp in
527 | let last_two = Bytes.create 2 in
528 | Bytes.set last_two 0 '\x00'; Bytes.set last_two 1 '\x00';
529 | let current = Bytes.create 2 in
530 | (try
531 | while !starting_point < end_len - 2 do Bytes.(
532 | set last_two 0 (get http_resp (!starting_point - 2));
533 | set last_two 1 (get http_resp (!starting_point - 1));
534 | set current 0 (get http_resp (!starting_point));
535 | set current 1 (get http_resp (!starting_point + 1));
536 | let cr = Bytes.of_string "\r\n" in
537 | if last_two = cr && current = cr then raise Exit;
538 | incr starting_point
539 | )
540 | done;
541 | with Exit -> ());
542 | let leftover = end_len - !starting_point in
543 | let status_line, headers = match Originals.(
544 | Bytes.sub_string http_resp 0 !starting_point
545 | |> S.split_on_char '\n'
546 | |> L.map S.trim
547 | |> L.filter (( <> ) "")
548 | ) with
549 | | [] -> failwith "headers_and_body"
550 | | s::h -> s, h
551 | in
552 | (status_line,
553 | headers,
554 | Bytes.sub http_resp !starting_point leftover
555 | |> fun body -> if trim_body then Bytes.trim body else body)
556 |
557 | let get ?(trim_body=true) route =
558 | let error_reason = ref Can_only_handle_http in
559 | let uri = Uri.of_string route in
560 | let request = Uri.scheme uri >>= fun s ->
561 | match s with
562 | | x when x <> "http" && x <> "https" -> None
563 | | _ -> Uri.host uri >>= fun host ->
564 | (try Some (Originals.U.open_connection (address host))
565 | with
566 | Not_found -> error_reason := Host_lookup_failed; None
567 | | Invalid_argument _ -> error_reason := No_ip_from_hostname; None
568 | ) >>= fun (in_chan, out_chan) ->
569 | Originals.U.(setsockopt (descr_of_out_channel out_chan) TCP_NODELAY true);
570 | let msg host =
571 | Originals.P.sprintf
572 | "GET / HTTP/1.1\r\n\
573 | Host:%s\r\n\
574 | User-Agent: OCaml - Podge\r\n\
575 | Connection: close\r\n\r\n" host
576 | in
577 | really_output out_chan (Bytes.of_string(msg host));
578 | let all = read_all in_chan in
579 | (try close_in in_chan; close_out out_chan with _ -> ());
580 | Some (headers_and_body ~trim_body all)
581 | in
582 | match request with None -> Error !error_reason | Some (a,b,c) -> Ok (a,b,Bytes.to_string c)
583 |
584 | let post ?(trim_reply=true) ?post_body route =
585 | let uri = Uri.of_string route in
586 | let error_reason = ref Post_failed in
587 | let request =
588 | Uri.scheme uri >>= fun s ->
589 | match s with
590 | | x when x <> "http" && x <> "https" -> None
591 | | _ -> Uri.host uri >>= fun host ->
592 | let (in_chan, out_chan) = Originals.U.open_connection (address host) in
593 | let fd_ = Originals.U.descr_of_out_channel out_chan in
594 | Originals.(U.setsockopt fd_ U.TCP_NODELAY true);
595 | let post_request = match post_body with
596 | | Some b ->
597 | let b' = Bytes.of_string b in
598 | Originals.P.sprintf "POST %s HTTP/1.1\r\n\
599 | Host:%s\r\n\
600 | Content-length: %d\r\n\
601 | User-Agent: OCaml - Podge\r\n\
602 | Connection: close\r\n\r\n%s"
603 | (Uri.path_and_query uri)
604 | host
605 | (Bytes.length b')
606 | (b)
607 | | None ->
608 | Originals.P.sprintf "POST %s HTTP/1.1\r\n\
609 | Host:%s\r\n\
610 | User-Agent: OCaml - Podge\r\n\
611 | Connection: close\r\n\r\n"
612 | (Uri.path_and_query uri)
613 | host
614 | in
615 | really_output out_chan (Bytes.of_string post_request);
616 | let reply = read_all in_chan in
617 | (try close_in in_chan; close_out out_chan with _ -> ());
618 | Some (headers_and_body ~trim_body:trim_reply reply)
619 | in
620 | match request with None -> Error !error_reason | Some (a,b,c) -> Ok (a, b, Bytes.to_string c)
621 | end
622 |
623 | (** Simple querying for Xml nodes, keys order matters *)
624 | module Xml : sig
625 |
626 | val query_node_of_file : keys:string list -> path:string -> string
627 | val query_node_of_string : keys:string list -> str:string -> string
628 |
629 | end = struct
630 |
631 | open Ezxmlm
632 |
633 | let rec dig keys xml_doc final_result =
634 | match keys with
635 | | [] -> final_result
636 | | outer_most :: rest ->
637 | let new_xml =
638 | try member (Originals.S.lowercase_ascii outer_most) xml_doc
639 | with _ -> member (Originals.S.lowercase_ascii outer_most) xml_doc
640 | in
641 | dig rest new_xml (data_to_string new_xml)
642 |
643 | let query_node_of_file ~keys ~path =
644 | let (_, xml) = from_channel (open_in path) in
645 | dig keys xml ""
646 |
647 | let query_node_of_string ~keys ~str =
648 | let (_, xml) = from_string str in
649 | dig keys xml ""
650 |
651 | end
652 |
653 | module ANSITerminal = struct
654 |
655 | open Originals
656 |
657 | (** Create a colorized message, presumably for a log message *)
658 | let colored_message ?(t_color=T.Yellow) ?(m_color=T.Blue) ?(with_time=true) str =
659 | let just_time = T.sprintf [T.Foreground t_color] "%s " (Unix.time_now ()) in
660 | let just_message = T.sprintf [T.Foreground m_color] "%s" str in
661 | if with_time then just_time ^ just_message else just_message
662 |
663 | end
664 |
--------------------------------------------------------------------------------
/podge.opam:
--------------------------------------------------------------------------------
1 | opam-version: "2.0"
2 | maintainer: "Edgar Aroutiounian "
3 | authors: "Edgar Aroutiounian "
4 | homepage: "https://github.com/fxfactorial/podge"
5 | bug-reports: "https://github.com/fxfactorial/podge/issues"
6 | license: "BSD-3-Clause"
7 | dev-repo: "git+http://github.com/fxfactorial/podge.git"
8 | build: [
9 | ["dune" "build" "-p" name "-j" jobs]
10 | ["dune" "build" "@doc" "-p" name] {with-doc}
11 | ]
12 | depends: [
13 | "ocaml" {>= "4.04.0"}
14 | "ANSITerminal" {>= "0.7"}
15 | "base-unix"
16 | "cohttp" {>= "0.21.0"}
17 | "ezxmlm" {>= "1.0.1"}
18 | "dune" {>= "1.11.0"}
19 | "re" {>= "1.7.1"}
20 | "tyxml" {>= "4.0.1"}
21 | "yojson" {>= "1.3.3"}
22 | "astring" {>= "0.8.3"}
23 | ]
24 | synopsis: "Shortcuts and helpers for common tasks in OCaml ecosystem"
25 | description: """
26 | If you're doing any modern OCaml then you're doubtlessly annoyed by
27 | the state of libraries and committing to one of the big ones can be
28 | restricting. Podge is a single module containing specialized modules
29 | for their respectives usages for seemingly common tasks.
30 |
31 | Some conveniences with Podge:
32 | 1) Web: Simple HTTP get/put requests
33 | 2) Yojson: Pretty printing, updating keys, and removing key-value pairs
34 | from Yojson objects
35 | 3) Unix: Read output of a process, simple daemonize.
36 | 4) Xml: Simple reading of node content given a path.
37 | 5) ANSITerminal: Create a colored string for the shell,
38 | with or without current time.
39 | 6) Other modules: Math, Html5, Analyze, Cohttp, Printf, Debugging,
40 | and List.
41 |
42 | Podge is especially useful for Hackathons and prototyping."""
43 |
--------------------------------------------------------------------------------
/podge_listing.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/fxfactorial/podge/3142e417545ba90c959e0f181d36e62f53b588cc/podge_listing.gif
--------------------------------------------------------------------------------