logarion/src/logarion_cli.ml

let version = "0.5"
open Cmdliner
open Logarion
module C = Archive.Configuration
module Lpath = Logarion.Lpath

let conf () =
  let module Config = Confix.Config.Make (Confix.ConfixToml) in
  let archive_res =
    let open Confix.Config in
    Confix.Config.Path.with_file "config.toml"
    &> Config.from_path
    |> Config.to_record C.of_config
  in
  match archive_res with
  | Ok config -> config
  | Error str -> prerr_endline str; exit 1

let create_dir dir = Bos.OS.Dir.create (Fpath.v dir)

let create_dir_msg ?(descr="") dir res =
  let () = match res with
    | Ok true -> print_endline ("Created " ^ descr ^ " directory " ^ dir)
    | Ok false -> print_endline ("Reinitialise existing " ^ descr ^ " directory " ^ dir)
    | Error (`Msg msg) -> prerr_endline @@ "Failed making " ^ descr ^ ". " ^ msg
  in
  res

let copy ?(recursive = false) src dst =
  Bos.OS.Cmd.run (Bos.Cmd.(v "cp" %% (on recursive @@ v "-r") % src % dst))

let init _force =
  let rec create_dirs = function
    | [] -> ()
    | (dir,descr)::tl ->
       match create_dir dir |> create_dir_msg ~descr dir with
       | Ok _ -> create_dirs tl
       | Error _ -> ()
  in
  let dirs = [
      ".logarion", "Logarion";
      ".logarion/static", "static files";
      ".logarion/html-templates", "templates";
    ]
  in
  let toml_data =
    let open Toml in
    let open TomlTypes in
    of_key_values [
        key "archive",
        TTable (
            of_key_values [
                key "title", TString "";
                key "owner", TString (Bos.OS.Env.opt_var "USER"  ~absent:"");
                key "email", TString (Bos.OS.Env.opt_var "EMAIL" ~absent:"");
                key "uuid", TString (Meta.Id.(generate () |> to_string));
          ]);
        key "web",
        TTable (
            of_key_values [
                key "url", TString "http://localhost:3666";
                key "stylesheets", TArray ( NodeString ["main.css"] );
                key "static_dir", TString ".logarion/static";
          ]);
        key "templates", TTable (of_key_values []);
      ]
  in
  create_dirs dirs;
  let config_file = open_out "config.toml" in
  output_bytes config_file (Toml.Printer.string_of_table toml_data |> Bytes.of_string);
  close_out config_file

let init_term =
  let force =
    let doc = "Initialise repository even if directory is non empty" in
    Arg.(value & flag & info ["f"; "force"] ~doc)
  in
  Term.(const init $ force),
  Term.info
    "init" ~doc:"initialise a logarion repository in present directory"
    ~man:[ `S "DESCRIPTION"; `P "Create a repository in current directory" ]

let create_term =
  let title =
    Arg.(value & pos 0 string "" & info [] ~docv:"TITLE" ~doc:"Title for new article")
  in
  let f title =
    let conf = conf () in
    let t = match title with "" -> "Draft" | _ -> title in
    let note =
      let meta =
        let open Meta in
        let authors = AuthorSet.singleton Author.({ name = conf.C.owner; address = Uri.of_string conf.C.email }) in
        let date = Date.({ created = Some (Ptime_clock.now ()); published = None; edited = None }) in
        { (blank ()) with title = t; authors; date }
      in
      Note.({ (blank ()) with meta })
    in
    File.Lwt.with_note (File.store conf.C.repository) note
    |> Lwt_main.run
    |> ignore
  in
  Term.(const f $ title),
  Term.info "create"
            ~doc:"create a new article"
            ~man:[ `S "DESCRIPTION";  `P "Create a new article, with title 'Draft' when none provided"]

let convert directory =
  let module Config = Confix.Config.Make (Confix.ConfixToml) in

  let toml_config =
    let open Confix.Config in
    Path.with_file "config.toml"
    |> function Ok cfg -> Config.from_path cfg | Error str -> prerr_endline str; exit 1
  in
  let config = Config.to_record_or_exit Logarion.Archive.Configuration.of_config toml_config in

  let module L = Logarion.Archive.Make(File) in
  let store = File.store config.repository in
  let archive = L.{ config; store } in
  let notes =
    List.filter Meta.(fun n -> CategorySet.published n.Note.meta.categories)
    @@ File.to_list L.note_lens archive.store
  in
  let metas =
    List.filter Meta.(fun m -> CategorySet.published m.categories && CategorySet.listed m.categories)
    @@ File.to_list ~order:(L.recency_order) L.meta_lens archive.store
  in

  let template_config = toml_config in
  let module T = Converters.Template in
  let header = T.header_converter template_config in
  let body = T.body_converter template_config in
  let style = T.default_style in
  let linker x = match Fpath.(relativize ~root:(v "/") (v x)) with Some l -> Fpath.to_string l | None -> "" in
  let page_of_log metas = T.page_of_log linker header config metas in
  let page_of_index metas = T.page_of_index linker header config metas in
  let page_of_note note = T.page_of_note linker header body config note in
  let path_of_note note = directory ^ "/" ^ Meta.alias note.Note.meta ^ ".html" in
  let file_creation path content =
    let out = open_out path in
    output_string out content;
    close_out out
  in
  match create_dir directory |> create_dir_msg ~descr:"export" directory with
  | Error _ -> ()
  | Ok _ ->
     match copy ~recursive:true ".logarion/static" (directory) with
      | Ok _ ->
         let note_write note = file_creation (path_of_note note) (page_of_note ~style note) in
         List.iter note_write notes;
         file_creation (directory ^ "/log.html") (page_of_log ~style metas);
         file_creation (directory ^ "/index.html") (page_of_index ~style metas);
         file_creation (directory ^ "/feed.atom") (Converters.Atom.feed config "/" (L.note_with_id archive) metas)
      | Error (`Msg m) -> prerr_endline m

let convert_term =
  let directory =
    Arg.(value & pos 0 string "html-conversion" & info [] ~docv:"Directory" ~doc:"Directory to convert to")
  in
  Term.(const convert $ directory),
  Term.info
    "convert" ~doc:"convert archive to HTML"
    ~man:[ `S "DESCRIPTION"; `P "Create a repository in current directory" ]

let default_cmd =
  Term.(ret (const (`Help (`Pager, None)))),
  Term.info "logarion" ~version ~doc:"an article collection & publishing system"
    ~man:[ `S "BUGS";
           `P "Submit bugs <mailto:logarion@lists.orbitalfox.eu?subject=[Issue] summary-here>"; ]

let cmds = [ init_term; create_term; convert_term ]

let () =
  Random.self_init();
  match Term.eval_choice default_cmd cmds with `Error _ -> exit 1 | _ -> exit 0