Initial commit

lib/drivers.ml

@@ -0,0 +1,84 @@
+open Import
+
+module Cli = struct
+  open Cmdliner
+
+  module Terms = struct
+    let year =
+      let doc = "Run problems from year $(docv)." in
+      Arg.(value & opt (some int) None & info [ "year" ] ~docv:"YEAR" ~doc)
+
+    let day =
+      let doc = {|Run problem number "day" $(docv).|} in
+      Arg.(value & opt (some int) None & info [ "day" ] ~docv:"DAY" ~doc)
+
+    let part =
+      let doc = "Run problem part $(docv)." in
+      Arg.(value & opt (some int) None & info [ "part" ] ~docv:"PART" ~doc)
+
+    let auth_token =
+      let doc =
+        "Some operations require authenticating with adventofcode.com . This \
+         is the token used for authentication."
+      in
+      let env = Cmd.Env.(info "AUTH_TOKEN" ~doc) in
+      Arg.(
+        value
+        & opt (some string) None
+        & info [ "auth_token" ] ~docv:"AUTH_TOKEN" ~doc ~env)
+
+    let submit =
+      let doc =
+        "If set, attempts to submit the problem output to adventofcode.com."
+      in
+      Arg.(value & flag & info [ "submit" ] ~docv:"SUBMIT" ~doc)
+  end
+
+  let run (year : int option) (day : int option) (part : int option)
+      (auth_token : string option) (submit : bool) : unit Cmdliner.Term.ret =
+    match (year, day, part) with
+    | None, _, _ -> `Error (false, {|"year" argument required.|})
+    | _, None, _ -> `Error (false, {|"day" argument required.|})
+    | _, _, None -> `Error (false, {|"part" argument required.|})
+    | Some year, Some day, Some part -> (
+        let output =
+          let@ (run_mode : Problem_runner.Run_mode.t) =
+            match (auth_token, submit) with
+            | None, true ->
+                Error {|Must provide AUTH_TOKEN when using --submit|}
+            | token, false ->
+                Ok
+                  (Problem_runner.Run_mode.Test_from_puzzle_input
+                     {
+                       credentials =
+                         Option.map Problem_runner.Credentials.of_auth_token
+                           token;
+                     })
+            | Some token, true ->
+                Ok
+                  (Problem_runner.Run_mode.Submit
+                     {
+                       credentials =
+                         Problem_runner.Credentials.of_auth_token token;
+                     })
+          in
+          Problem_runner.(run { year; day; part; run_mode })
+        in
+
+        match output with
+        | Ok output ->
+            print_endline output;
+            `Ok ()
+        | Error error_msg -> `Error (false, error_msg))
+
+  let main () =
+    let info = Cmd.info "tanenbaum" in
+    let cmd =
+      Cmd.v info
+        Term.(
+          ret
+            (const run $ Terms.year $ Terms.day $ Terms.part $ Terms.auth_token
+           $ Terms.submit))
+    in
+    exit @@ Cmdliner.Cmd.eval cmd
+end

lib/drivers.mli

@@ -0,0 +1,5 @@
+(** Interfaces with core libraries to provide a command-line interface. *)
+module Cli : sig
+  val main : unit -> unit
+  (** Runs Advent of Code problem runner, via a command-line interface. *)
+end

lib/dune

@@ -0,0 +1,14 @@
+(library
+ (name aoc)
+ (modules drivers problem_runner)
+ (libraries cmdliner piaf problems import))
+
+(library
+ (name import)
+ (wrapped false)
+ (modules import let fn)
+ (libraries fmt lwt))
+
+(library
+ (name problem)
+ (modules problem))

lib/fn.ml

@@ -0,0 +1,5 @@
+(** [f << g] composes [f] with [g] right-to-left -- i.e. [f (g x)] *)
+let (<<) f g x = f (g x)
+
+(** [f << g] composes [f] with [g] left-to-right -- i.e. [g (f x)] *)
+let (>>) f g x = g (f x)

lib/import.ml

@@ -0,0 +1,2 @@
+include Let
+include Fn

lib/let.ml

@@ -0,0 +1,4 @@
+let (let@) = Result.bind
+let (let+) = Lwt.bind
+let (let*) = Lwt_result.bind
+let (let-) = Option.bind

lib/problem.ml

@@ -0,0 +1,26 @@
+(** The type of an Advent of Code puzzle which can be run by Tanenbaum. *)
+module type T = sig
+  val year : int
+  (** The year that this puzzle is from. *)
+
+  val day : int
+  (** The day that this puzzle is from. *)
+
+  (** Contains specific to the first part of the puzzle. *)
+  module Part_1 : sig
+    val run : string -> (string, string) result
+    (** Runs the first part of the puzzle. 
+
+        This should return [Error] if something goes wrong during execution -- for example, there 
+        was a parsing error. If [Error] was returned, Tanenbaum will ignore the [--submit] flag. *)
+  end
+
+  (** Contains specific to the second part of the puzzle. *)
+  module Part_2 : sig
+    val run : string -> (string, string) result
+    (** Runs the second part of the puzzle. 
+
+        This should return [Error] if something goes wrong during execution -- for example, there 
+        was a parsing error. If [Error] was returned, Tanenbaum will ignore the [--submit] flag. *)
+  end
+end

lib/problem_runner.ml

@@ -0,0 +1,142 @@
+open Import
+
+module Credentials = struct
+  type t = string
+
+  let of_auth_token (x : string) : t = x
+
+  let to_headers (t : t) : (string * string) list =
+    [ ("Cookie", "session=" ^ t) ]
+end
+
+module Run_mode = struct
+  type t =
+    | Test_from_puzzle_input of { credentials : Credentials.t option }
+    | Submit of { credentials : Credentials.t }
+
+  let read_file (filename : string) : string =
+    let ch = open_in_bin filename in
+    let s = really_input_string ch (in_channel_length ch) in
+    close_in ch;
+    s
+
+  let write_file (filename : string) (contents : string) : unit =
+    let ch = open_out_bin filename in
+    let () = output_string ch contents in
+    close_out ch
+
+  let get_puzzle_input (year : int) (day : int)
+      (credentials : Credentials.t option) : (string, string) result =
+    (* Create cache directory structure *)
+    let () =
+      if not (Sys.file_exists "inputs") then Sys.mkdir "inputs" 0o777 else ()
+    in
+    let year_dir = Filename.concat "inputs" @@ string_of_int year in
+    let () =
+      if not (Sys.file_exists year_dir) then Sys.mkdir year_dir 0o777 else ()
+    in
+
+    (* Check if cached input exists *)
+    let filename =
+      Filename.concat year_dir @@ Format.sprintf "%02d.txt" day
+    in
+    if Sys.file_exists filename then Ok (read_file filename)
+      (* If not, fetch it from adventofcode.com *)
+    else
+      match credentials with
+      | None ->
+          Error "Cannot fetch input from adventofcode.com: missing credentials."
+      | Some credentials ->
+          Result.map_error Piaf.Error.to_string
+          @@ Lwt_main.run
+          @@
+          let uri =
+            Uri.of_string
+            @@ String.concat "/"
+                 [
+                   "https://adventofcode.com";
+                   string_of_int year;
+                   "day";
+                   string_of_int day;
+                   "input";
+                 ]
+          in
+          let headers = Credentials.to_headers credentials in
+          let* response = Piaf.Client.Oneshot.get ~headers uri in
+          let* body = Piaf.Body.to_string response.body in
+          write_file filename body;
+          Lwt_result.return body
+
+  let get_input (year : int) (day : int) : t -> (string, string) result =
+    function
+    | Test_from_puzzle_input { credentials } ->
+        get_puzzle_input year day credentials
+    | Submit { credentials } -> get_puzzle_input year day (Some credentials)
+
+  let cleanup (year : int) (day : int) (part : int) (output : string)
+      (run_mode : t) : (string option, string) result =
+    match run_mode with
+    | Test_from_puzzle_input _ -> Ok None
+    | Submit { credentials } ->
+        Result.map_error Piaf.Error.to_string
+        @@ Lwt_main.run
+        @@
+        let uri =
+          Uri.of_string
+          @@ String.concat "/"
+               [
+                 "https://adventofcode.com";
+                 string_of_int year;
+                 "day";
+                 string_of_int day;
+                 "answer";
+               ]
+        in
+        let headers = Credentials.to_headers credentials in
+        let headers =
+          headers @ [ ("Content-Type", "application/x-www-form-urlencoded") ]
+        in
+        let body =
+          Piaf.Body.of_string @@ Fmt.(str "level=%d&answer=%s" part output)
+        in
+        let* response = Piaf.Client.Oneshot.post ~headers ~body uri in
+        let* body = Piaf.Body.to_string response.body in
+        Lwt_result.return (Some body)
+end
+
+module Options = struct
+  type t = { year : int; day : int; part : int; run_mode : Run_mode.t }
+end
+
+let run_problem (module Problem : Problem.T) (run_mode : Run_mode.t)
+    (year : int) (day : int) (part : int) : (string, string) result =
+  let@ input = Run_mode.get_input year day run_mode in
+  let@ result =
+    match part with
+    | 1 -> Problem.Part_1.run input
+    | 2 -> Problem.Part_2.run input
+    | p -> Error (Format.sprintf {|Invalid part "%d". Expected "1" or "2".|} p)
+  in
+  let@ cleanup_result = Run_mode.cleanup year day part result run_mode in
+  let () =
+    match cleanup_result with None -> () | Some result -> print_endline result
+  in
+  Ok result
+
+let find_problem (year : int) (day : int) :
+    ((module Problem.T), string) result =
+  match
+    List.find_opt
+      (fun (module Problem : Problem.T) ->
+        Problem.year = year && Problem.day = day)
+      Problems.All.all
+  with
+  | Some p -> Ok p
+  | None ->
+      Error
+        (Format.sprintf "Problem (year = %d, day = %d) not implemented."
+           year day)
+
+let run (options : Options.t) : (string, string) result =
+  let@ problem = find_problem options.year options.day in
+  run_problem problem options.run_mode options.year options.day options.part

lib/problem_runner.mli

@@ -0,0 +1,43 @@
+(** Credentials are used to authenticate with [adventofcode.com], to automate some slightly 
+    annoying things that you need to do when working on puzzle solutions. *)
+module Credentials : sig
+  type t
+  (** A complete set of credentials used to authenticate with [adventofcode.com]. *)
+
+  val of_auth_token : string -> t
+  (** [of_auth_token session_token] constructs a [t] from the session token issued by 
+      [adventofcode.com]. *)
+end
+
+(** Specifies the way that we'd like our problem runner to run. *)
+module Run_mode : sig
+  (** Specifies the way that we'd like our problem runner to run. *)
+  type t =
+    | Test_from_puzzle_input of { credentials : Credentials.t option }
+        (** Indicates that we'd like to test the puzzle solution that we're working on, without 
+        submitting the answer to [adventofcode.com] *)
+    | Submit of { credentials : Credentials.t }
+        (** Indicates that we'd like to run a puzzle solution, and if successful, submit the answer to
+        [adventofcode.com] *)
+end
+
+(** Fully configures an invocation of [run]. *)
+module Options : sig
+  type t = {
+    year : int;
+        (** The "year" of the puzzle that we'd like to run -- e.g. [2015], or [2022]. *)
+    day : int;
+        (** The "day" of the puzzle that we'd like to run -- e.g. [1], or [18]. *)
+    part : int;
+        (** The "part" of the puzzle that we'd like to run -- i.e. [1], or [2]. *)
+    run_mode : Run_mode.t;
+        (** The "run_mode" of the puzzle that we'd like to run. See [Run_mode] for more details. *)
+  }
+  (** Fully configures an invocation of [run]. *)
+end
+
+val run : Options.t -> (string, string) result
+(** [run options] runs a puzzle solution, configured by [options]. 
+
+    This may return [Error] for a number of reasons -- the returned [string] should indicate what
+    went wrong. *)

lib/problems/dune

@@ -0,0 +1,12 @@
+(rule
+ (target all.ml)
+ (deps
+  (:problem_files
+   (glob_files "./problem*{[!r][!e].ml,.re}"))
+  (:generator generator/gen.exe))
+ (action
+  (run %{generator} %{target} %{problem_files})))
+
+(library
+ (name problems)
+ (libraries problem import str))

lib/problems/generator/dune

@@ -0,0 +1,4 @@
+(executable
+ (name gen)
+ (modules gen)
+ (libraries fmt))

lib/problems/generator/gen.ml

@@ -0,0 +1,21 @@
+let pp_module_name (f : Format.formatter) (module_name : string) : unit =
+  Fmt.pf f "(module %s: Problem.T)" module_name
+
+let pp_file (f : Format.formatter) (module_names : string list) : unit =
+  Fmt.(
+    pf f {ocaml|let all: (module Problem.T) list = [%a]|ocaml}
+      (list ~sep:semi pp_module_name)
+      module_names)
+
+let () =
+  let output_filename = Array.get Sys.argv 1 in
+  let filenames =
+    Sys.argv |> Array.to_list |> List.tl |> List.tl
+    |> List.map
+         (String.mapi (fun i c -> if i = 0 then Char.uppercase_ascii c else c))
+    |> List.map (fun s -> String.sub s 0 (String.length s - 3))
+  in
+  let contents = Fmt.str "%a" pp_file filenames in
+  let c = open_out output_filename in
+  output_string c contents;
+  close_out c