reynir.dk/src/model.ml

open Yocaml

let article_path file =
  let filename = basename $ replace_extension file "html" in
  filename |> into "posts"

module Author = struct
  type t = {
    name : string;
  }

  let equal a b = String.equal a.name b.name

  let make name = { name }

  let from (type a) (module V : Metadata.VALIDABLE with type t = a) obj =
    V.object_and
      (fun assoc ->
         let open Validate.Applicative in
         make
         <$> V.(required_assoc string) "name" assoc)
      obj

  let default_author =
    make "Reynir Björnsson"

  let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a) { name } =
    D.[ "name", string name ]
end

module Article = struct
  type t = {
    title : string;
    date : Date.t;
    author : Author.t;
  }

  let make title date author =
    { title; date; author }

  let from (type a) (module V : Metadata.VALIDABLE with type t = a) obj =
    V.object_and
      (fun assoc ->
         let open Validate.Applicative in
         make
         <$> V.(required_assoc string) "title" assoc
         <*> V.(required_assoc (Metadata.Date.from (module V))) "date" assoc
         <*> V.(optional_assoc_or (Author.from (module V))) "author" assoc ~default:Author.default_author)
      obj

  let from_string (module V : Metadata.VALIDABLE) = function
    | None -> Validate.error $ Error.Required_metadata [ "Article" ]
    | Some str ->
      let open Validate.Monad in
      V.from_string str >>=
      from (module V)

  let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a)
      { title; date; author } =
    D.[ "title", string title;
        "date", object_ $ Metadata.Date.inject (module D) date;
        "author", object_ $ Author.inject (module D) author ];
end

module Articles = struct
  type t = (string * Article.t) list

  let make path article = (path, article)

  let sort articles =
    List.sort
      (fun (_, a) (_, b) ->
         ~-(Date.compare a.Article.date b.Article.date))
      articles

  let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a) articles =
    D.[
      "articles",
      list
        (List.map (fun (path, article) ->
             object_ @@
             [ "location", string path ] @
             Article.inject (module D) article)
            articles)
    ]
end

module With_path (V : Metadata.INJECTABLE) = struct
  type t = {
    path : string;
    extension : V.t;
  }
  
  let merge path v =
    { path; extension=v; }

  let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a) { path; extension } =
    D.[ "path", string path ] @ V.inject (module D) extension
end

module Page = struct
  type t = {
    title : string;
    head_extra : string option;
  }
  
  let make title head_extra = { title; head_extra }

  let from (type a) (module V : Metadata.VALIDABLE with type t = a) obj =
    V.object_and
      (fun assoc ->
         let open Validate.Applicative in
         make
         <$> V.(required_assoc string) "title" assoc
         <*> V.(optional_assoc string) "head_extra" assoc)
      obj

  let from_string (module V : Metadata.VALIDABLE) = function
    | None -> Validate.valid { title = "TODO"; head_extra = None }
    | Some str ->
      Validate.Monad.bind
        (from (module V))
        (V.from_string str)

  let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a)
      { title; head_extra } =
    let r = D.[ "title", string title ] in
    match head_extra with
    | None -> r
    | Some head_extra -> ("head_extra", D.string head_extra) :: r
end

module With_layout (V : Metadata.INJECTABLE) = struct
  type t = {
    title : string;
    head_extra : string option;
    extension : V.t
  }

  let merge ~title ~head_extra v =
    { title; head_extra; extension = v }

  let inject (type a) (module D : Key_value.DESCRIBABLE with type t = a)
      { title; head_extra; extension = v } =
    let r =
      D.[ "title", string title ] @
      V.inject (module D) v
    in
    match head_extra with
    | None -> r
    | Some head_extra -> ("head_extra", D.string head_extra) :: r
end