concurrent requests with lwt

bin/main.ml

@@ -134,7 +134,7 @@ let pp (day : Unix.tm) matches =
       ppd_matches
 
 let f () =
-  let fetched = Lib.fetch_all tournaments in
+  let fetched = Lwt_main.run @@ Lib.fetch_all tournaments in
   let today = Unix.time () |> Unix.localtime in
   let tomorrow = Unix.time () +. (60. *. 60. *. 24.) |> Unix.localtime in
   let header = "### schedules" in

lib/dune

@@ -2,4 +2,4 @@
   (name api)
   (public_name api)
   (libraries cohttp cohttp-lwt-unix cohttp-curl-lwt yojson ppx_deriving_yojson.runtime)
-  (preprocess (pps ppx_yojson_conv ppx_deriving.show ppx_expect)))
+  (preprocess (pps ppx_yojson_conv ppx_deriving.show ppx_expect lwt_ppx)))

lib/lib.ml

@@ -1,5 +1,7 @@
 open Ppx_yojson_conv_lib.Yojson_conv.Primitives
 open Printf
+open Lwt.Infix
+
 
 type api_status = {
   code : int;
@@ -30,10 +32,10 @@ type api_tournament_info = { name : string; slug : string }
 [@@yojson.allow_extra_fields] [@@deriving yojson, show]
 
 type api_score = {
-  current : int;
+  current : int  [@default 0];
-  period1 : int;
+  period1 : int  [@default 0];
-  period2 : int;
+  period2 : int  [@default 0];
-  normaltime : int;
+  normaltime : int [@default 0];
 }
 [@@yojson.allow_extra_fields] [@@deriving yojson, show]
 
@@ -48,8 +50,8 @@ type api_match = {
   tournament : api_tournament_info;
   homeTeam : api_team;
   awayTeam : api_team;
-  (* homeScore: api_team; *)
+  homeScore : api_score;
-  (* awayScore: api_team; *)
+  awayScore : api_score;
   status : api_status;
   time : api_time;
   startTimestamp : int;
@@ -60,16 +62,16 @@ type api_events = { events : api_match list }
 [@@yojson.allow_extra_fields] [@@deriving yojson, show]
 
 type half =
-  | FirstHalf of { injury_time1 : int option }
+  | FirstHalf of { injury_time1 : int option; period_start_timestamp : int }
-  | HalfTime of { injury_time1 : int }
+  | HalfTime of { injury_time1 : int option }
   | SecondHalf of {
-      injury_time1 : int;
+      injury_time1 : int option;
-      (* second_half_start_timestamp: int; *)
       injury_time2 : int option;
+      period_start_timestamp : int;
     }
 [@@deriving show]
 
-type time = { start_timestamp : int; half : half } [@@deriving show]
+type score = { home_score : int; away_score : int } [@@deriving show]
 
 type status =
   | NotStarted of { start_timestamp : int }
@@ -77,8 +79,8 @@ type status =
   | Postponed
   | Canceled
   | Delayed
-  | InProgress of time
+  | InProgress of { score : score; start_timestamp : int; half : half }
-  | Completed of time
+  | Completed of { score : score; start_timestamp : int }
 [@@deriving show]
 
 (* TODO: round info *)
@@ -165,7 +167,7 @@ let ( let* ) = Lwt.bind
 exception Status_Not_found
 
 (* TODO: handle "resolution failed: name resolution failed" *)
-let get url : string =
+let get url =
   let http_get url =
     Stdlib.flush Stdlib.stdout;
     let req_headers =
@@ -183,11 +185,10 @@ let get url : string =
       Lwt.return (Ok b)
     else Lwt.return @@ Error (Cohttp.Code.reason_phrase_of_code code)
   in
-  Lwt_main.run
+  let* result = http_get url in
-    (let* result = http_get url in
      match result with
      | Error str -> failwith str
-     | Ok result -> Lwt.return result)
+     | Ok r -> Lwt.return r
 
 let matches_of_api_events (e : api_events) =
   e.events
@@ -196,59 +197,114 @@ let matches_of_api_events (e : api_events) =
            home_team = m.homeTeam;
            away_team = m.awayTeam;
            status =
-             (let typ = m.status.typ in
+             (match (m.status.description, m.status.typ, m.time) with
-              let h =
+             | ( "Halftime",
-                match m.time with
+                 "inprogress",
-                | {
+                 {
-                 injuryTime1 = x;
+                   injuryTime1 = x;
-                 injuryTime2 = None;
+                   injuryTime2 = _;
-                 currentPeriodStartTimestamp = _;
+                   currentPeriodStartTimestamp = _;
-                } ->
+                 } ) ->
-                    FirstHalf { injury_time1 = x }
+                 InProgress
-                | {
+                   {
-                 injuryTime1 = Some x;
+                     start_timestamp = m.startTimestamp;
-                 injuryTime2 = y;
+                     half = HalfTime { injury_time1 = x };
-                 currentPeriodStartTimestamp = _;
+                     score =
-                } ->
+                       {
-                    SecondHalf { injury_time1 = x; injury_time2 = y }
+                         home_score = m.homeScore.current;
-                | {
+                         away_score = m.awayScore.current;
-                 injuryTime1 = None;
+                       };
-                 injuryTime2 = Some y;
+                   }
-                 currentPeriodStartTimestamp = _;
+             | ( "1st half",
-                } ->
+                 "inprogress",
-                    SecondHalf { injury_time1 = 0; injury_time2 = Some y }
+                 {
-              in
+                   injuryTime1 = x;
-              let t = { start_timestamp = m.startTimestamp; half = h } in
+                   injuryTime2 = None;
-              match typ with
+                   currentPeriodStartTimestamp = Some z;
-              | "notstarted" ->
+                 } ) ->
-                  NotStarted { start_timestamp = m.startTimestamp }
+                 InProgress
-              | "postponed" -> Postponed
+                   {
-              | "canceled" -> Canceled
+                     start_timestamp = m.startTimestamp;
-              | "suspended" -> Suspended { start_timestamp = m.startTimestamp }
+                     half =
-              | "inprogress" -> InProgress t
+                       FirstHalf
-              | "finished" -> Completed t
+                         { injury_time1 = x; period_start_timestamp = z };
-              | "delayed" -> Delayed
+                     score =
-              | _ -> failwith (sprintf "unrecognized match type: %s" typ));
+                       {
+                         home_score = m.homeScore.current;
+                         away_score = m.awayScore.current;
+                       };
+                   }
+             | ( "2nd half",
+                 "inprogress",
+                 {
+                   injuryTime1 = x;
+                   injuryTime2 = y;
+                   currentPeriodStartTimestamp = Some z;
+                 } ) ->
+                 InProgress
+                   {
+                     start_timestamp = m.startTimestamp;
+                     half =
+                       SecondHalf
+                         {
+                           injury_time1 = x;
+                           injury_time2 = y;
+                           period_start_timestamp = z;
+                         };
+                     score =
+                       {
+                         home_score = m.homeScore.current;
+                         away_score = m.awayScore.current;
+                       };
+                   }
+             | "AP", "finished", _
+             | "AET", "finished", _
+             | "Ended", "finished", _ ->
+                 Completed
+                   {
+                     start_timestamp = m.startTimestamp;
+                     score =
+                       {
+                         home_score = m.homeScore.current;
+                         away_score = m.awayScore.current;
+                       };
+                   }
+             | _, "notstarted", _ ->
+                 NotStarted { start_timestamp = m.startTimestamp }
+             | _, "canceled", _ -> Canceled
+             | _, "postponed", _ -> Postponed
+             | _, "suspended", _ ->
+                 Suspended { start_timestamp = m.startTimestamp }
+             | a, b, _ ->
+                 failwith
+                 @@ Printf.sprintf "impossible: %s %s %s" a b
+                      (show_api_time m.time));
          })
 
+
 let fetch_matches ctx =
   let g order (* "last" for previous matches "next" for future matches *) =
-    try
+    try%lwt
-      sprintf
+      let url =
-        (* TLS fingerprinting is in place and it's been used to block our requests once
+        sprintf
+          (* TLS fingerprinting is in place and it's been used to block our requests once
            their systems detect we've been abusing their private API.
            TLS handshakes can only happen with secure connections using
            HTTPS, so using plain HTTP makes it impossible for that to happen,
            which they do generously accept. *)
-        "http://www.sofascore.com/api/v1/unique-tournament/%d/season/%d/events/%s/0"
+          "http://www.sofascore.com/api/v1/unique-tournament/%d/season/%d/events/%s/0"
-        ctx.id ctx.season order
+          ctx.id ctx.season order
-      |> get |> Yojson.Safe.from_string |> api_events_of_yojson
+      in
-      |> matches_of_api_events
+
+      get url >|= Yojson.Safe.from_string >|= api_events_of_yojson >|= matches_of_api_events
     with
-    | Status_Not_found -> []
+    | Status_Not_found -> Lwt.return []
     | Ppx_yojson_conv_lib__Yojson_conv.Of_yojson_error (exn, _) ->
         failwith @@ Printexc.to_string exn
   in
-  Tournament.make ctx (List.append (g "last") (g "next"))
+  let* last = g "last" in
+  let* next = g "next" in
+  Lwt.return @@ Tournament.make ctx @@ List.append last next
 
-let fetch_all tournaments = tournaments |> List.map fetch_matches
+let fetch_all tournaments = 
+  tournaments |> List.map fetch_matches |> Lwt.all