diff --git a/bin/main.ml b/bin/main.ml index 9855986..18c21ad 100644 --- a/bin/main.ml +++ b/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 diff --git a/lib/dune b/lib/dune index 8527db5..77d0aee 100644 --- a/lib/dune +++ b/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))) diff --git a/lib/lib.ml b/lib/lib.ml index 7b4b2e5..c5eae0b 100644 --- a/lib/lib.ml +++ b/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; - period1 : int; - period2 : int; - normaltime : int; + current : int [@default 0]; + period1 : int [@default 0]; + period2 : int [@default 0]; + 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; *) - (* awayScore: api_team; *) + homeScore : api_score; + 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 } - | HalfTime of { injury_time1 : int } + | FirstHalf of { injury_time1 : int option; period_start_timestamp : int } + | HalfTime of { injury_time1 : int option } | SecondHalf of { - injury_time1 : int; - (* second_half_start_timestamp: int; *) + injury_time1 : int option; 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 - | Completed of time + | InProgress of { score : score; start_timestamp : int; half : half } + | 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 - let h = - match m.time with - | { - injuryTime1 = x; - injuryTime2 = None; - currentPeriodStartTimestamp = _; - } -> - FirstHalf { injury_time1 = x } - | { - injuryTime1 = Some x; - injuryTime2 = y; - currentPeriodStartTimestamp = _; - } -> - SecondHalf { injury_time1 = x; injury_time2 = y } - | { - injuryTime1 = None; - injuryTime2 = Some y; - currentPeriodStartTimestamp = _; - } -> - SecondHalf { injury_time1 = 0; injury_time2 = Some y } - in - let t = { start_timestamp = m.startTimestamp; half = h } in - match typ with - | "notstarted" -> - NotStarted { start_timestamp = m.startTimestamp } - | "postponed" -> Postponed - | "canceled" -> Canceled - | "suspended" -> Suspended { start_timestamp = m.startTimestamp } - | "inprogress" -> InProgress t - | "finished" -> Completed t - | "delayed" -> Delayed - | _ -> failwith (sprintf "unrecognized match type: %s" typ)); + (match (m.status.description, m.status.typ, m.time) with + | ( "Halftime", + "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 = Some z; + } ) -> + InProgress + { + 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 = 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 - sprintf - (* TLS fingerprinting is in place and it's been used to block our requests once + 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. 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" - ctx.id ctx.season order - |> get |> Yojson.Safe.from_string |> api_events_of_yojson - |> matches_of_api_events + "http://www.sofascore.com/api/v1/unique-tournament/%d/season/%d/events/%s/0" + ctx.id ctx.season order + in + + 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