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,44 +197,95 @@ 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;
+                   injuryTime2 = _;
+                   currentPeriodStartTimestamp = _;
+                 } ) ->
+                 InProgress
+                   {
+                     start_timestamp = m.startTimestamp;
+                     half = HalfTime { injury_time1 = x };
+                     score =
+                       {
+                         home_score = m.homeScore.current;
+                         away_score = m.awayScore.current;
+                       };
+                   }
+             | ( "1st half",
+                 "inprogress",
+                 {
                    injuryTime1 = x;
                    injuryTime2 = None;
-                 currentPeriodStartTimestamp = _;
+                   currentPeriodStartTimestamp = Some z;
-                } ->
+                 } ) ->
-                    FirstHalf { injury_time1 = x }
+                 InProgress
-                | {
+                   {
-                 injuryTime1 = Some x;
+                     start_timestamp = m.startTimestamp;
+                     half =
+                       FirstHalf
+                         { injury_time1 = x; period_start_timestamp = z };
+                     score =
+                       {
+                         home_score = m.homeScore.current;
+                         away_score = m.awayScore.current;
+                       };
+                   }
+             | ( "2nd half",
+                 "inprogress",
+                 {
+                   injuryTime1 = x;
                    injuryTime2 = y;
-                 currentPeriodStartTimestamp = _;
+                   currentPeriodStartTimestamp = Some z;
-                } ->
+                 } ) ->
-                    SecondHalf { injury_time1 = x; injury_time2 = y }
+                 InProgress
-                | {
+                   {
-                 injuryTime1 = None;
+                     start_timestamp = m.startTimestamp;
-                 injuryTime2 = Some y;
+                     half =
-                 currentPeriodStartTimestamp = _;
+                       SecondHalf
-                } ->
+                         {
-                    SecondHalf { injury_time1 = 0; injury_time2 = Some y }
+                           injury_time1 = x;
-              in
+                           injury_time2 = y;
-              let t = { start_timestamp = m.startTimestamp; half = h } in
+                           period_start_timestamp = z;
-              match typ with
+                         };
-              | "notstarted" ->
+                     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 }
-              | "postponed" -> Postponed
+             | _, "canceled", _ -> Canceled
-              | "canceled" -> Canceled
+             | _, "postponed", _ -> Postponed
-              | "suspended" -> Suspended { start_timestamp = m.startTimestamp }
+             | _, "suspended", _ ->
-              | "inprogress" -> InProgress t
+                 Suspended { start_timestamp = m.startTimestamp }
-              | "finished" -> Completed t
+             | a, b, _ ->
-              | "delayed" -> Delayed
+                 failwith
-              | _ -> failwith (sprintf "unrecognized match type: %s" typ));
+                 @@ 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
+      let url =
         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.
@@ -242,13 +294,17 @@ let fetch_matches ctx =
            which they do generously accept. *)
           "http://www.sofascore.com/api/v1/unique-tournament/%d/season/%d/events/%s/0"
           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