diff --git a/.ocamlinit b/.ocamlinit new file mode 100644 index 0000000..cc14f36 --- /dev/null +++ b/.ocamlinit @@ -0,0 +1 @@ +open Lwt.Infix diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 0000000..5f11a5b --- /dev/null +++ b/Dockerfile @@ -0,0 +1 @@ +FROM ocaml/opam:debian diff --git a/README.md b/README.md new file mode 100644 index 0000000..7cdba71 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ + +# TODO + +- [ ] (2025-07-16) Lista de eventos com todos os gols por timestamp do dia. +- [ ] (2025-07-16) Tabelas de classificaΓ§Γ£o. +- [ ] (2025-07-16) AtualizaΓ§Γ£o em tempo real. diff --git a/api.opam b/api.opam index cea7e74..d906f9e 100644 --- a/api.opam +++ b/api.opam @@ -14,6 +14,7 @@ depends: [ "ocaml" "ppx_deriving_yojson" "cohttp-curl-lwt" + "lwt_ppx" "cohttp-lwt-unix" "lwt_ssl" "ppx_expect" diff --git a/bin/main.ml b/bin/main.ml index 9855986..8773720 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -7,6 +7,7 @@ let tournaments : Lib.tournament_scrape_context list = id = 357; season = 69619; name = "CWC"; + emoji = "πŸ‡§πŸ‡·"; filter_foreigners = true; timezone_offset = None; }; @@ -14,6 +15,7 @@ let tournaments : Lib.tournament_scrape_context list = id = 384; season = 70083; name = "LIBERTADORES"; + emoji = "πŸ‡§πŸ‡·"; filter_foreigners = false; timezone_offset = None; }; @@ -21,6 +23,7 @@ let tournaments : Lib.tournament_scrape_context list = id = 480; season = 70070; name = "SUDAMERICANA"; + emoji = "πŸ‡§πŸ‡·"; filter_foreigners = false; timezone_offset = None; }; @@ -28,6 +31,7 @@ let tournaments : Lib.tournament_scrape_context list = id = 373; season = 71944; name = "COPA DO BRASIL"; + emoji = "πŸ‡§πŸ‡·"; filter_foreigners = false; timezone_offset = None; }; @@ -35,6 +39,7 @@ let tournaments : Lib.tournament_scrape_context list = id = 1596; season = 69430; name = "COPA DO NORDESTE"; + emoji = "πŸ‡§πŸ‡·"; filter_foreigners = false; timezone_offset = None; }; @@ -42,6 +47,7 @@ let tournaments : Lib.tournament_scrape_context list = id = 1024; season = 70664; name = "COPA ARGENTINA"; + emoji = "πŸ‡§πŸ‡·"; filter_foreigners = false; timezone_offset = None; }; @@ -49,6 +55,7 @@ let tournaments : Lib.tournament_scrape_context list = id = 325; season = 72034; name = "BRA1"; + emoji = "πŸ‡§πŸ‡·"; filter_foreigners = false; timezone_offset = None; }; @@ -56,6 +63,7 @@ let tournaments : Lib.tournament_scrape_context list = id = 155; season = 77826; name = "ARG1"; + emoji = "πŸ‡§πŸ‡·"; filter_foreigners = false; timezone_offset = None; }; @@ -63,6 +71,7 @@ let tournaments : Lib.tournament_scrape_context list = id = 278; season = 71306; name = "URY1"; + emoji = "πŸ‡§πŸ‡·"; filter_foreigners = false; timezone_offset = None; }; @@ -70,6 +79,7 @@ let tournaments : Lib.tournament_scrape_context list = id = 11536; season = 77825; name = "COL1"; + emoji = "πŸ‡§πŸ‡·"; filter_foreigners = false; timezone_offset = Some ~-5; }; @@ -77,6 +87,7 @@ let tournaments : Lib.tournament_scrape_context list = id = 1335; season = 76050; name = "COPA COLOMBIA"; + emoji = "πŸ‡§πŸ‡·"; filter_foreigners = false; timezone_offset = Some ~-5; }; @@ -84,6 +95,7 @@ let tournaments : Lib.tournament_scrape_context list = id = 11653; season = 71131; name = "CHL1"; + emoji = "πŸ‡§πŸ‡·"; filter_foreigners = false; timezone_offset = Some ~-4; }; @@ -91,6 +103,7 @@ let tournaments : Lib.tournament_scrape_context list = id = 390; season = 72603; name = "BRA2"; + emoji = "πŸ‡§πŸ‡·"; filter_foreigners = false; timezone_offset = None; }; @@ -98,6 +111,7 @@ let tournaments : Lib.tournament_scrape_context list = id = 1221; season = 71100; name = "COPA CHILE"; + emoji = "πŸ‡§πŸ‡·"; filter_foreigners = false; timezone_offset = Some ~-4; }; @@ -105,6 +119,7 @@ let tournaments : Lib.tournament_scrape_context list = id = 11541; season = 69831; name = "PRY1"; + emoji = "πŸ‡§πŸ‡·"; filter_foreigners = false; timezone_offset = None; }; @@ -130,11 +145,11 @@ let pp (day : Unix.tm) matches = in if ppd_matches = "" then "" else - sprintf ">%s %02d/%02d:\n%s" (weekday day.tm_wday) day.tm_mday day.tm_mon + sprintf ">%s %02d/%02d:\n%s" (weekday day.tm_wday) day.tm_mday (succ day.tm_mon) ppd_matches let f () = - let fetched = Lib.fetch_all tournaments in + let fetched = Lwt_main.run @@ Lib.fetch_all_tournaments 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/changelog.txt b/changelog.txt new file mode 100644 index 0000000..b7a088e --- /dev/null +++ b/changelog.txt @@ -0,0 +1,24 @@ +##### changelog: +2024-06-14 - rentry page initial release. +2024-06-16 - included ecuador as a conmebol country. + - fix formatting issues when there are no matches or all matches are concluded at a day. +2024-06-17 - added copa america. +2024-06-19 - added stats. + - added flag frequency counter. +2024-06-20 - tracking of multiple threads for stats. + - added posts per hour counter. +2024-06-21 - whitelist concacaf countries in copa america. +2024-08-?? - remove stats. +2025-01-06 - temporary script sunset. +2025-03-26 - update hardcoded queries. revives the script. + - mitigate the views counter inflation with a third-party counter. +2025-04-06 - reorder copa chile. +2025-06-04 - second attempt at reviving the script. +2025-06-07 - added copa colombia. +2025-06-14 - added club world cup filtering foreign clubs. +2025-06-27 - rewrite the script in ocaml. +2025-07-04 - updated PRY1. +2025-07-09 - added copa nordeste. +2025-07-11 - updated ARG1 and COL1. +2025-07-12 - use short team names. + diff --git a/dune-project b/dune-project index 36cdbce..5ffeaec 100644 --- a/dune-project +++ b/dune-project @@ -23,6 +23,7 @@ ocaml ppx_deriving_yojson cohttp-curl-lwt + lwt_ppx cohttp-lwt-unix lwt_ssl ppx_expect 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/foobar.ml b/lib/foobar.ml new file mode 100644 index 0000000..af43965 --- /dev/null +++ b/lib/foobar.ml @@ -0,0 +1,46 @@ +type match' = + string (* home team *) * int (* goal difference *) * string (* away team *) + +let matches = + [ + ("foo", 1, "car"); + ("foo", 0, "bar"); + ("foo", 1, "far"); + ("car", 1, "bar"); + ("foo", ~-1, "bar"); + ("tar", 1, "fir"); + ("bar", 1, "qux"); + ("jor", ~-1, "far"); + ("xir", 1, "kar"); + ("car", ~-1, "qux"); + ("far", 1, "qux"); + ("car", 1, "foo"); + ] + +let way a b = + let rec aux (at : string) (visited : string list) (accum : match' list) = + if at = b then [ List.rev accum ] + else + let matches = + matches |> List.filter (function _, score, _ -> score <> 0) + in + let h = + matches + |> List.filter (function home, score, away -> + score > 0 && home = at && not (List.exists (( = ) away) visited)) + |> List.map (function (_, _, away) as x -> + aux away (at :: visited) (x :: accum)) + |> List.concat + in + let a = + matches + |> List.filter (function home, score, away -> + score < 0 && away = at && not (List.exists (( = ) home) visited)) + |> List.map (function (home, _, _) as x -> + aux home (at :: visited) (x :: accum)) + |> List.concat + in + a @ h + in + aux a [] [] + diff --git a/lib/lib.ml b/lib/lib.ml index 7b4b2e5..b81f46e 100644 --- a/lib/lib.ml +++ b/lib/lib.ml @@ -1,5 +1,6 @@ open Ppx_yojson_conv_lib.Yojson_conv.Primitives open Printf +open Lwt.Infix type api_status = { code : int; @@ -8,7 +9,12 @@ type api_status = { } [@@deriving yojson, show] -type api_country = { alpha2 : string; alpha3 : string; name : string } +type api_country = { + alpha2 : string; + alpha3 : string; + name : string; + slug : string; +} [@@yojson.allow_extra_fields] [@@deriving yojson, show] type api_team_colors = { primary : string; secondary : string; text : string } @@ -17,23 +23,27 @@ type api_team_colors = { primary : string; secondary : string; text : string } type api_team = { id : int; name : string; - short_name : string option; [@key "shortName"] [@yojson.option] + shortName : string option; [@yojson.option] gender : string; teamColors : api_team_colors; country : api_country; } [@@yojson.allow_extra_fields] [@@deriving yojson, show] -let team_name x = match x.short_name with Some x -> x | None -> x.name +let team_name x = match x.shortName with Some x -> x | None -> x.name -type api_tournament_info = { name : string; slug : string } +type api_tournament = { + name : string; + slug : string; + country : api_country option; [@yojson.option] +} [@@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] @@ -45,13 +55,14 @@ type api_time = { [@@yojson.allow_extra_fields] [@@deriving yojson, show] type api_match = { - tournament : api_tournament_info; + tournament : api_tournament; homeTeam : api_team; awayTeam : api_team; - (* homeScore: api_team; *) - (* awayScore: api_team; *) + homeScore : api_score; + awayScore : api_score; status : api_status; time : api_time; + id : int; startTimestamp : int; } [@@yojson.allow_extra_fields] [@@deriving yojson, show] @@ -60,16 +71,107 @@ 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 } - | SecondHalf of { - injury_time1 : int; - (* second_half_start_timestamp: int; *) + | First_Half of { injury_time1 : int option; period_start_timestamp : int } + | Half_Time of { injury_time1 : int option } + | Second_Half of { + injury_time1 : int option; + injury_time2 : int option; + period_start_timestamp : int; + } + | First_Extra of { + injury_time1 : int option; + injury_time2 : int option; + period_start_timestamp : int; + } + | Extra_Time_Half_Time of { + injury_time1 : int option; injury_time2 : int option; } + | Second_Extra of { + injury_time1 : int option; + injury_time2 : int option; + period_start_timestamp : int; + } + | Extra_Time_Await + | Penalties [@@deriving show] -type time = { start_timestamp : int; half : half } [@@deriving show] +type api_standing_rows = { + team : api_team; + position : int; + matches : int; + points : int; + wins : int option; [@yojon.option] [@default None] + scoresFor : int option; [@yojon.option] [@default None] + scoresAgainst : int option; [@yojon.option] [@default None] + losses : int option; [@yojon.option] [@default None] + draws : int option; [@yojon.option] [@default None] + pointsPerGame : float option; [@yojon.option] [@default None] + pointsPrevPrevSeason : int option; [@yojon.option] [@default None] + pointsPrevSeason : int option; [@yojon.option] [@default None] + pointsCurrSeason : int option; [@yojon.option] [@default None] +} +[@@yojson.allow_extra_fields] [@@deriving yojson, show] + +type api_standing = { + name : string; + rows : api_standing_rows list; + updatedAtTimestamp : int; +} +[@@yojson.allow_extra_fields] [@@deriving yojson, show] + +type api_standings_total = { standings : api_standing list } +[@@deriving yojson, show] + +type api_short_match = { winnerCode : int } [@@deriving yojson] + +(* type api_team_events_table = (string * api_short_match list) Hashtbl.t *) +(* [@@deriving yojson] *) +(**) +(* type api_team_events_total = { *) +(* tournamentTeamEvents : (string, api_team_events_table) Hashtbl.t *) +(* } *) +(* [@@deriving yojson] *) + +type match_info = { tournament : string } [@@deriving yojson] + +(* type inner_map = (string, match_info list) Hashtbl.t *) +(* [@@deriving yojson] *) +(**) +(* type outer_map = (string, inner_map) Hashtbl.t *) +(* [@@deriving yojson] *) + +type normal_table_row = { + team : api_team; + position : int; + matches : int; + points : int; + wins : int; + scoresFor : int; + scoresAgainst : int; + losses : int; + draws : int; +} + +type promedios_table_row = { + team : api_team; + position : int; + matches : int; + points : int; + pointsPerGame : float; + pointsPrevPrevSeason : int; + pointsPrevSeason : int; + pointsCurrSeason : int; +} + +type table_rows = + | Normal of normal_table_row list + | Promedios of promedios_table_row list + +type table = { name : string; rows : table_rows } + +(* TODO penalties *) +type score = { home_score : int; away_score : int } [@@deriving show] type status = | NotStarted of { start_timestamp : int } @@ -77,18 +179,24 @@ 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 *) -type match' = { status : status; home_team : api_team; away_team : api_team } +type match' = { + status : status; + home_team : api_team; + away_team : api_team; + api_id : int; +} [@@deriving show] type tournament_scrape_context = { id : int; season : int; name : string; + emoji : string; filter_foreigners : bool; timezone_offset : int option (* assumes UTC-3 if None *); } @@ -96,7 +204,7 @@ type tournament_scrape_context = { let mmod a b = ((a mod b) + b) mod b -let is_conmebol x = +let is_conmebol (x : api_team) = match x.country.alpha2 with | "AR" | "BO" | "BR" | "CL" | "CO" | "EC" | "PY" | "PE" | "UY" | "VE" -> true | _ -> false @@ -165,13 +273,13 @@ 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 = Cohttp.Header.( add (init ()) "X-Captcha" - "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJleHAiOjE3NTI0OTgxMTR9.sZk2yhTk5TeWu_kXE7RO__LDYKlPgZuaA7KKFsB_0GQ") + "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJleHAiOjE3NTQzMTc2MTJ9.sMoqrrTQMoq1JJRJqn-pbOtPIOlOfh5gjrniyUKX_04") in let* resp, body = Cohttp_lwt_unix.Client.get ~headers:req_headers @@ Uri.of_string url @@ -183,57 +291,276 @@ 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 - match result with - | Error str -> failwith str - | Ok result -> Lwt.return result) + let* result = http_get url in + match result with Error str -> failwith str | Ok r -> Lwt.return r + +let tables_of_api_standings_total (s : api_standings_total) : table list = + let must_some = function None -> failwith "impossible" | Some x -> x in + let table_of_api_standing (x : api_standing) = + let row = List.nth x.rows 0 in + match row.wins with + | Some _ -> + let of_normal (x : api_standing_rows) = + { + team = x.team; + position = x.position; + matches = x.matches; + points = x.points; + wins = must_some x.wins; + scoresFor = must_some x.scoresFor; + scoresAgainst = must_some x.scoresAgainst; + losses = must_some x.losses; + draws = must_some x.draws; + } + in + { name = x.name; rows = Normal (List.map of_normal x.rows) } + | None -> + let of_promedios (x : api_standing_rows) = + { + team = x.team; + position = x.position; + matches = x.matches; + points = x.points; + pointsPerGame = must_some x.pointsPerGame; + pointsPrevPrevSeason = must_some x.pointsPrevPrevSeason; + pointsPrevSeason = must_some x.pointsPrevSeason; + pointsCurrSeason = must_some x.pointsCurrSeason; + } + in + { name = x.name; rows = Promedios (List.map of_promedios x.rows) } + in + List.map table_of_api_standing s.standings let matches_of_api_events (e : api_events) = e.events |> List.map (fun (m : api_match) -> + let period_start_timestamp = + match m.time with + | { + currentPeriodStartTimestamp = Some x; + injuryTime1 = _; + injuryTime2 = _; + } -> + x + | { + currentPeriodStartTimestamp = None; + injuryTime1 = _; + injuryTime2 = _; + } -> + m.startTimestamp + in { + api_id = m.id; 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 = Half_Time { injury_time1 = x }; + score = + { + home_score = m.homeScore.current; + away_score = m.awayScore.current; + }; + } + | ( "1st half", + "inprogress", + { + injuryTime1 = x; + injuryTime2 = None; + currentPeriodStartTimestamp = _; + } ) -> + InProgress + { + start_timestamp = m.startTimestamp; + half = + First_Half { injury_time1 = x; period_start_timestamp }; + score = + { + home_score = m.homeScore.current; + away_score = m.awayScore.current; + }; + } + | ( "2nd half", + "inprogress", + { + injuryTime1 = x; + injuryTime2 = y; + currentPeriodStartTimestamp = _; + } ) -> + InProgress + { + start_timestamp = m.startTimestamp; + half = + Second_Half + { + injury_time1 = x; + injury_time2 = y; + period_start_timestamp; + }; + score = + { + home_score = m.homeScore.current; + away_score = m.awayScore.current; + }; + } + | ( "1st extra", + "inprogress", + { + injuryTime1 = x; + injuryTime2 = y; + currentPeriodStartTimestamp = _; + } ) -> + InProgress + { + start_timestamp = m.startTimestamp; + half = + First_Extra + { + injury_time1 = x; + injury_time2 = y; + period_start_timestamp; + }; + score = + { + home_score = m.homeScore.current; + away_score = m.awayScore.current; + }; + } + | ( "Extra time halftime", + "inprogress", + { + injuryTime1 = x; + injuryTime2 = y; + currentPeriodStartTimestamp = _; + } ) -> + InProgress + { + start_timestamp = m.startTimestamp; + half = + Extra_Time_Half_Time + { injury_time1 = x; injury_time2 = y }; + score = + { + home_score = m.homeScore.current; + away_score = m.awayScore.current; + }; + } + | ( "2nd extra", + "inprogress", + { + injuryTime1 = x; + injuryTime2 = y; + currentPeriodStartTimestamp = _; + } ) -> + InProgress + { + start_timestamp = m.startTimestamp; + half = + Second_Extra + { + injury_time1 = x; + injury_time2 = y; + period_start_timestamp; + }; + score = + { + home_score = m.homeScore.current; + away_score = m.awayScore.current; + }; + } + | ( "Awaiting penalties", + "inprogress", + { + injuryTime1 = _; + injuryTime2 = _; + currentPeriodStartTimestamp = _; + } ) -> + InProgress + { + start_timestamp = m.startTimestamp; + half = Penalties; + score = + { + home_score = m.homeScore.current; + away_score = m.awayScore.current; + }; + } + | ( "Penalties", + "inprogress", + { + injuryTime1 = _; + injuryTime2 = _; + currentPeriodStartTimestamp = _; + } ) -> + InProgress + { + start_timestamp = m.startTimestamp; + half = Penalties; + score = + { + home_score = m.homeScore.current; + away_score = m.awayScore.current; + }; + } + | ( "Awaiting extra time", + "inprogress", + { + injuryTime1 = _; + injuryTime2 = _; + currentPeriodStartTimestamp = _; + } ) -> + InProgress + { + start_timestamp = m.startTimestamp; + half = Extra_Time_Await; + score = + { + home_score = m.homeScore.normaltime; + away_score = m.awayScore.normaltime; + }; + } + | "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 } + | _, "delayed", _ -> Delayed + | 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 +(* https://www.sofascore.com/api/v1/unique-tournament/480/season/70070/rounds *) +(* https://www.sofascore.com/api/v1/unique-tournament/480/season/70070/events/round/636/slug/playoff-round *) + +let fetch ctx order (* "last" for previous matches "next" for future matches *) + = + 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. @@ -241,14 +568,40 @@ let fetch_matches ctx = 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 - with - | Status_Not_found -> [] - | 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")) + ctx.id ctx.season + (match order with `Last -> "last" | `Next -> "next") + in + get url >|= Yojson.Safe.from_string >|= api_events_of_yojson + >|= matches_of_api_events + with + | Status_Not_found -> Lwt.return [] + | Ppx_yojson_conv_lib__Yojson_conv.Of_yojson_error (exn, _) -> raise exn -let fetch_all tournaments = tournaments |> List.map fetch_matches +let fetch_all_matches ctx = + let* last = fetch ctx `Last in + let* next = fetch ctx `Next in + Lwt.return @@ Tournament.make ctx @@ List.append last next + +let fetch_all_tournaments tournaments = + tournaments |> List.map fetch_all_matches |> Lwt.all + +let fetch_match_details id = + let url = sprintf "https://www.sofascore.com/api/v1/event/%d" id in + get url >|= Yojson.Safe.from_string + +let standings context = + let url = + sprintf + "https://www.sofascore.com/api/v1/unique-tournament/%d/season/%d/standings/total" + context.id context.season + in + get url >|= Yojson.Safe.from_string >|= api_standings_total_of_yojson + >|= tables_of_api_standings_total + +(* let last_five_matches context = *) +(* let url = *) +(* sprintf "https://www.sofascore.com/api/v1/unique-tournament/%d/season/%d/team-events/total" *) +(* context.id context.season *) +(* in *) +(* (* get url >|= Yojson.Safe.from_string >|= *) *) +(* ;; *) diff --git a/website/dune b/website/dune new file mode 100644 index 0000000..1e68279 --- /dev/null +++ b/website/dune @@ -0,0 +1,6 @@ +(executable + (public_name website) + (name main) + (libraries api dream tyxml) + (preprocess (pps tyxml-ppx)) + ) diff --git a/website/main.ml b/website/main.ml new file mode 100644 index 0000000..046622e --- /dev/null +++ b/website/main.ml @@ -0,0 +1,504 @@ + +open Printf +open Api + + +let context: Lib.tournament_scrape_context list = [ + { + id = 384; + season = 70083; + name = "LIBERTADORES"; + emoji = "🌎"; + filter_foreigners = false; + timezone_offset = None; + }; + { + id = 480; + season = 70070; + name = "SUDAMERICANA"; + emoji = "🌎"; + filter_foreigners = false; + timezone_offset = None; + }; + { + id = 373; + season = 71944; + name = "COPA DO BRASIL"; + emoji = "πŸ‡§πŸ‡·"; + filter_foreigners = false; + timezone_offset = None; + }; + { + id = 325; + season = 72034; + name = "BRAZIL 1"; + emoji = "πŸ‡§πŸ‡·"; + filter_foreigners = false; + timezone_offset = None; + }; + { + id = 390; + season = 72603; + name = "BRAZIL 2"; + emoji = "πŸ‡§πŸ‡·"; + filter_foreigners = false; + timezone_offset = None; + }; + { + id = 1596; + season = 69430; + name = "COPA DO NORDESTE"; + emoji = "πŸ‡§πŸ‡·"; + filter_foreigners = false; + timezone_offset = None; + }; + { + id = 1024; + season = 70664; + name = "COPA ARGENTINA"; + emoji = "πŸ‡¦πŸ‡·"; + filter_foreigners = false; + timezone_offset = None; + }; + { + id = 155; + season = 77826; + name = "ARGENTINA 1, CLAUSURA"; + emoji = "πŸ‡¦πŸ‡·"; + filter_foreigners = false; + timezone_offset = None; + }; + { + id = 278; + season = 71306; + name = "URUGUAY 1"; + emoji = "πŸ‡ΊπŸ‡Ύ"; + filter_foreigners = false; + timezone_offset = None; + }; + { + id = 11536; + season = 77825; + name = "COLOMBIA 1"; + emoji = "πŸ‡¨πŸ‡΄"; + filter_foreigners = false; + timezone_offset = Some ~-5; + }; + { + id = 1335; + season = 76050; + name = "COPA COLOMBIA"; + emoji = "πŸ‡¨πŸ‡΄"; + filter_foreigners = false; + timezone_offset = Some ~-5; + }; + { + id = 11653; + season = 71131; + name = "CHILE 1"; + emoji = "πŸ‡¨πŸ‡±"; + filter_foreigners = false; + timezone_offset = Some ~-4; + }; + { + id = 1221; + season = 71100; + name = "COPA CHILE"; + emoji = "πŸ‡¨πŸ‡±"; + filter_foreigners = false; + timezone_offset = Some ~-4; + }; + { + id = 11541; + season = 69831; + name = "PARAGUAY 1, CLAUSURA"; + emoji = "πŸ‡΅πŸ‡Ύ"; + filter_foreigners = false; + timezone_offset = None; + }; +] +;; + +let ( let& ) a b = + match a with + | None -> None + | Some x -> b x +;; + +let ( let* ) = Lwt.bind ;; + +let my_header () = + let open Tyxml.Html in + header ~a:[a_style "padding: var(--main-margin); px; margin: var(--main-margin); "] [ + div [ + a ~a:[a_href "/"; a_style "text-decoration-color: unset; color: unset"] [txt "index"] + ] ; + div [ + let ts = Unix.localtime @@ Unix.time () in + txt @@ sprintf "last updated: %02d:%02d:%02d" ts.tm_hour ts.tm_min ts.tm_sec + ] + ]; +;; + +let my_head title' = + let open Tyxml.Html in + (head (title (txt title')) [ + style [ txt {| + :root { + --main-bg: #eee; + --main-margin: 3px; + --celeste: #9ed1ff; + } + * { + margin: 0; + } + html, body { + height: 100%; font-size: 13px; + } + a { + text-decoration-color: unset; + color: unset; + } + .match-table { + text-decoration: none; + transition: background-color 0.035s; + } + .match-table:last-child { + border-bottom: 0 !important + } + .match-table:hover { + background-color: var(--main-bg); + border-radius 3px 3px; + } + .standing tbody tr:nth-child(odd) { + background-color: var(--celeste); + } + td { + padding: var(--main-margin); + text-align: center; + } + td:nth-child(2), thead td { + text-align: left; + } + td:nth-child(3) { + font-weight: bold; + } + |}] + ]) +;; + +let box ?style elements = + let s = + match style with + | Some x -> x + | None -> "" + in + let attr = + [Tyxml.Html.a_style @@ "padding: var(--main-margin); border-radius: var(--main-margin); \ + margin: var(--main-margin); " ^ s] + in + Tyxml.Html.section ~a:attr elements +;; + +let greet (tournaments: Lib.Tournament.t list) = + let open Tyxml.Html in + let filter_day day mon (x: Unix.tm) = + x.tm_mday = day && x.tm_mon = mon + in + let today = + Unix.time () |> Unix.localtime + in + html + (my_head "index") + (body [ + my_header (); + main ~a:[a_style "margin: auto; display: flex; flex-direction: row; flex-wrap: wrap"] + (tournaments + |> List.filter_map @@ fun x -> (x + |> Lib.Tournament.matches + |> List.filter_map (fun (match': Lib.match') -> + let& ts = + match match'.status with + | Delayed | Suspended _ | Postponed | Canceled -> None + | InProgress { start_timestamp; half = _; score = _ } -> Some start_timestamp + | NotStarted { start_timestamp } -> Some start_timestamp + | Completed { start_timestamp; score = _ } -> Some start_timestamp + in + let match_ts = + Unix.localtime @@ float_of_int ts + in + if not @@ filter_day today.tm_mday today.tm_mon match_ts + then None + else + Some ( + a ~a:[a_class ["match-table"] ; a_href @@ sprintf "/match/%d" match'.api_id ; + a_style "display: flex; justify-content: space-between; border-bottom: 1px black solid; \ + padding-top: calc(var(--main-margin) * 2);"] + [ + div ~a:[a_style "display: flex; width: 145px; justify-content: space-between;"] [ + div ~a:[] [ + div ~a:[a_style "white-space: nowrap"] [txt @@ Lib.team_name match'.home_team]; + div ~a:[a_style "white-space: nowrap"] [txt @@ Lib.team_name match'.away_team]; + ] ; + (match match'.status with + | NotStarted _ | Delayed | Suspended _ | Postponed | Canceled -> div [] + | Completed {score = {home_score; away_score}; start_timestamp = _} -> + (* print_string (Lib.show_api_score home_score) ; *) + div ~a:[] [ + div ~a:[] [txt @@ string_of_int home_score]; + div ~a:[] [txt @@ string_of_int away_score]; + ] + | InProgress {score = {home_score; away_score}; start_timestamp = _; half = _} -> + div ~a:[] [ + div ~a:[] [txt @@ string_of_int home_score]; + div ~a:[] [txt @@ string_of_int away_score]; + ]) + ] ; + let status_attr = [a_style "text-align: right; min-width: 87px"] in + let attr = [a_style "color: red; font-weight: bold; text-align: right; min-width: 87px"] in + match match'.status with + | Delayed | Suspended _ | Postponed | Canceled -> failwith "impossible" + | Completed _ -> div ~a:status_attr [ txt "finished" ] + | NotStarted _ -> + let text = + sprintf "%02d:%02d" match_ts.tm_hour match_ts.tm_min + in + div ~a:[] [ txt text ] + | InProgress { start_timestamp = _; half; score = _} -> + match half with + | First_Half { injury_time1; period_start_timestamp } -> + let duration = (Unix.time ()) -. (float_of_int period_start_timestamp) in + let duration_minutes = (duration /. 60.) in + let text = + if duration_minutes < 45. then + sprintf "1T %02.0f'" duration_minutes + else + match injury_time1 with + | Some it -> + sprintf "1T 45+%02d/%02d'" (int_of_float duration_minutes - 45) it + | None -> + sprintf "1T 45+%02d/??'" (int_of_float duration_minutes - 45) + in + div ~a:attr [ txt text ] + | Half_Time _ -> + div ~a:[a_style "color: red; font-weight: bold"] [ txt "HT" ] + | Second_Half { injury_time1 = _ ; injury_time2 ; period_start_timestamp } -> + let duration = (Unix.time ()) -. (float_of_int period_start_timestamp) in + let duration_minutes = (duration /. 60.) in + let text = + if duration_minutes < 45. then + sprintf "2T %02.0f'" duration_minutes + else + (match injury_time2 with + | Some it -> + sprintf "2T 45+%02d/%02d'" (int_of_float duration_minutes - 45) it + | None -> + sprintf "2T 45+%02d/??'" (int_of_float duration_minutes - 45)) + in + div ~a:attr [ txt text ] + | First_Extra { injury_time1 = _ ; injury_time2 = _ ; period_start_timestamp } -> + let duration = (Unix.time ()) -. (float_of_int period_start_timestamp) in + let duration_minutes = (duration /. 60.) in + let text = sprintf "1ET %02.0f'" duration_minutes + in + div ~a:attr [ txt text ] + | Extra_Time_Await -> + div ~a:attr [ txt "HT..?" ] + | Extra_Time_Half_Time { injury_time1 = _ ; injury_time2 = _ } -> + div ~a:attr [ txt "ET HT" ] + | Second_Extra { injury_time1 = _ ; injury_time2 = _ ; period_start_timestamp } -> + let duration = (Unix.time ()) -. (float_of_int period_start_timestamp) in + let duration_minutes = (duration /. 60.) in + let text = sprintf "2ET %02.0f'" duration_minutes + in + div ~a:attr [ txt text ] + | Penalties -> + div ~a:attr [ txt "PEN" ] ; + ] + )) + |> fun y -> + if List.length y = 0 then None else + Some (box ~style:"min-width: 200px;" + [ + header [ + a ~a:[a_href @@ sprintf "/tournament/%d" x.context.id] + [h3 [txt @@ sprintf "%s %s" x.context.emoji x.context.name]]; + h4 [txt @@ sprintf "(%d/%d) Today" today.tm_mon today.tm_mday]; + ]; + main y + ] + ))) + ; + footer []; + ]) +;; + +let match_details_page _ = + let open Tyxml.Html in + html + (my_head "index") + (body [ + my_header () ; + main [ + box + [ ] + ]; + footer [] + ] + ) +;; + +let tournament_page (tournament: Lib.Tournament.t) (tables: Lib.table list) = + let open Tyxml.Html in + let my_table (t: Lib.table) = + let attr = + [a_style "border-collapse: collapse; border: 1px solid black; height: min-content;"; + a_class ["standing"]] + in + let tab = + match t.rows with + | Lib.Normal rows -> + table ~a:attr ~thead:(thead [ + tr [ + td [txt "#"] ; + td [txt "Name"] ; + td [txt "P"] ; + td [txt "M"] ; + td [txt "W"] ; + td [txt "D"] ; + td [txt "L"] ; + td [txt "GF"] ; + td [txt "Diff"] ; + td [txt "GA"] ; + ] + ]) + (rows + |> List.map (fun ({team; points; matches; wins; scoresFor; + scoresAgainst; losses; draws; position}: Lib.normal_table_row) -> + let is_playing = + tournament.matches + |> List.find_map (fun (x: Lib.match') -> + match x.status with + | InProgress y -> + let is_home = x.home_team.id = team.id in + if is_home || x.away_team.id = team.id then + Some (is_home, y.score) else None + | _ -> None + ) + in + let attr = + match is_playing with + | Some _ -> [a_style "color: red; font-weight: bold"] + | None -> [] + in + tr [ + td ~a:attr [txt @@ string_of_int position] ; + td ~a:attr [ + div ~a:[a_style "display: flex; justify-content: space-between;"] @@ + (div ~a:[a_style "text-wrap: nowrap"] [ txt @@ team.name ]) :: match is_playing with + | None -> [] + | Some (is_home, score) -> [ + let style = + "color: white; padding: 0 var(--main-margin) 0 var(--main-margin); \ + margin-left: var(--main-margin);" ^ + match is_home, Int.compare score.home_score score.away_score with + | false, -1 | true, 1 -> "background-color: green;" + | false, 1 | true, -1 -> "background-color: red;" + | false, 0 | true, 0 -> "background-color: grey;" + | _ -> failwith "impossible" + in + div ~a:[a_style style + ] [ + span [txt @@ string_of_int score.home_score ]; + span [txt "-"]; + span [txt @@ string_of_int score.away_score ]; + ] ] + ] ; + td ~a:attr [txt @@ string_of_int points] ; + td ~a:attr [txt @@ string_of_int matches] ; + td ~a:attr [txt @@ string_of_int wins] ; + td ~a:attr [txt @@ string_of_int draws] ; + td ~a:attr [txt @@ string_of_int losses] ; + td ~a:attr [txt @@ string_of_int scoresFor] ; + td ~a:attr [txt @@ string_of_int @@ scoresFor - scoresAgainst] ; + td ~a:attr [txt @@ string_of_int scoresAgainst] ; + ] + ) + ) + | Lib.Promedios rows -> + table ~a:attr ~thead:(thead [ + tr [ + td [txt "#"] ; + td [txt "Name"] ; + td [txt "PPG"] ; + td [txt "P"] ; + td [txt "M"] ; + td [txt "PPS"] ; + td [txt "PS"] ; + td [txt "CS"] ; + ] + ]) + (rows + |> List.map (fun ({team; points; matches; position; pointsPerGame; pointsPrevPrevSeason; + pointsPrevSeason; pointsCurrSeason;}: Lib.promedios_table_row) -> + tr [ + td [txt @@ string_of_int position] ; + td [txt @@ team.name] ; + td [txt @@ string_of_float pointsPerGame] ; + td [txt @@ string_of_int points] ; + td [txt @@ string_of_int matches] ; + td [txt @@ string_of_int pointsPrevPrevSeason] ; + td [txt @@ string_of_int pointsPrevSeason] ; + td [txt @@ string_of_int pointsCurrSeason] ; + ] + ) + ) + in + div [ + h3 ~a:[a_style "margin-bottom: var(--main-margin); text-wrap: nowrap;"] [txt t.name] ; + tab ; + ] + in + html + (my_head "index") + (body [ + my_header () ; + main [ + box + [ + h3 ~a:[] [txt @@ sprintf "%s %s" tournament.context.emoji tournament.context.name]; + div (List.rev @@ List.map my_table tables) + ] + ]; + footer [] + ] + ) +;; + +let html_to_string html = Format.asprintf "%a" (Tyxml.Html.pp ()) html ;; + +Lwt_main.run begin + Dream.serve + @@ Dream.logger + @@ Dream.router + [ + Dream.get "/" begin fun _ -> + let* data = Lib.fetch_all_tournaments context in + Dream.html @@ html_to_string @@ greet data + end ; + Dream.get "/match/:id" begin fun request -> + let id' = int_of_string @@ Dream.param request "id" in + let* data = Lib.fetch_match_details id' in + Dream.html @@ html_to_string @@ match_details_page data + end ; + Dream.get "/tournament/:id" begin fun request -> + let id' = int_of_string @@ Dream.param request "id" in + let ctx = + List.find (fun ({id; _}: Lib.tournament_scrape_context) -> id = id') context + in + let* matches = Lib.fetch ctx `Last in + let* standings = Lib.standings ctx in + Dream.html @@ html_to_string @@ tournament_page (Lib.Tournament.make ctx matches) standings + end + ] + end diff --git a/website/static/ae_mainbg.gif b/website/static/ae_mainbg.gif new file mode 100644 index 0000000..f7a4519 Binary files /dev/null and b/website/static/ae_mainbg.gif differ