config.ml

module Default =
struct
  module Log : Nixy_log.S

  type error = [ `Config_failure of String.t
               | `Config_doesnt_exist of String.t
               | `Read_exception of Exn.t ] with sexp

  type github_info = {owner: String.t; username: String.t; token: String.t} with sexp

  type repo_descr = String.t * String.t with sexp

  type t = {working_dir: String.t;
            sdid: String.t;
            github_info: github_info;
            publish_bucket: String.t;
            nix_repository: String.t;
            project_repositories: repo_descr List.t} with sexp, fields

  let load
    : log:Nixy_syslog.t -> config_file:String.t -> (t, error) Deferred.Result.t =
    fun ~log ~config_file ->
      Monitor.try_with (fun () ->
          Reader.file_contents config_file
          >>= fun contents ->
          let config = t_of_sexp @@ Sexp.of_string @@ String.strip contents in
          Nixy_syslog.info log "Config file loaded from %s" config_file ;
          return @@ config)
      >>= function
      | Error exn -> return @@ Error (`Read_exception exn)
      | ok_value -> return ok_value

  let initialize
    : log:Nixy_syslog.t -> config_file:String.t  -> (t, error) Deferred.Result.t =
    fun ~log ~config_file ->
      Nixy_syslog.debug log "Attempting to load config file from %s" config_file;
      Sys.file_exists config_file
      >>= function
      | `No ->
        Nixy_syslog.error log "Config file (%s) doesn't exist" config_file;
        return @@ Error (`Config_doesnt_exist config_file)
      | `Yes ->
        load ~log ~config_file
      | `Unknown ->
        Nixy_syslog.error log "Cannot read config  file (%s). Unknown file state detected."
          config_file;
        return @@ Error (`Config_failure config_file)
end

config.mli

open Core.Std
open Async.Std

module type S =
sig
  module Log : Nixy_log.S

  type github_info = {owner: String.t; username: String.t; token: String.t} with sexp

  type repo_descr = String.t * String.t with sexp

  type t = {working_dir: String.t;
            sdid: String.t;
            github_info: github_info;
            publish_bucket: String.t;
            nix_repository: String.t;
            project_repositories: repo_descr List.t} with sexp, fields

  type error = [ `Config_failure of String.t
               | `Config_doesnt_exist of String.t
               | `Read_exception of Exn.t ] with sexp

  val load
    : log:Log.t -> config_file:String.t -> (t, error) Deferred.Result.t

  val initialize: log:Log.t -> config_file:String.t
    -> (t, error) Deferred.Result.t
end

module Default : S

module Make (Log: Nixy_log.S) : S with module Log = Log

nixy_log.ml

open Core.Std
open Async.Std

(* This module produces log output that complies with
[rfc5424](http://tools.ietf.org/html/rfc5424) *)
module Syslog =
struct

  type facility =
    | Kernel_messages
    | User_level_messages
    | Mail_system
    | System_daemons
    | Security_authorization_messages_1
    | Messages_generated_internally_by_syslogd
    | Line_printer_subsystem
    | Network_news_subsystem
    | UUCP_subsystem
    | Clock_daemon_1
    | Security_authorization_messages_2
    | FTP_daemon
    | NTP_subsystem
    | Log_audit
    | Log_alert
    | Clock_daemon_2
    | Local_use_0
    | Local_use_1
    | Local_use_2
    | Local_use_3
    | Local_use_4
    | Local_use_5
    | Local_use_6
    | Local_use_7

  type severity =
    | Emergency
    | Alert
    | Critical
    | Error
    | Warning
    | Notice
    | Informational
    | Debug

  type tags = (String.t * String.t) List.t

  type t = {writer: Writer.t;
            facility: facility;
            severity: severity;
            build_id: String.t;
            hostname: String.t;
            app_name: String.t;
            procid: String.t;
            tags: tags;
            msgid: String.t;
            sdid: String.t;
            header_cache: String.t;
            tag_cache: String.t} with fields

  let int_of_facility
      : facility -> Int.t =
    function
    | Kernel_messages -> 0
    | User_level_messages -> 1
    | Mail_system -> 2
    | System_daemons -> 3
    | Security_authorization_messages_1 -> 4
    | Messages_generated_internally_by_syslogd -> 5
    | Line_printer_subsystem -> 6
    | Network_news_subsystem -> 7
    | UUCP_subsystem -> 8
    | Clock_daemon_1 -> 9
    | Security_authorization_messages_2 -> 10
    | FTP_daemon -> 11
    | NTP_subsystem -> 12
    | Log_audit -> 13
    | Log_alert -> 14
    | Clock_daemon_2 -> 15
    | Local_use_0  -> 16
    | Local_use_1 -> 17
    | Local_use_2 -> 18
    | Local_use_3 -> 19
    | Local_use_4 -> 20
    | Local_use_5 -> 21
    | Local_use_6 -> 22
    | Local_use_7 -> 23


  let int_of_severity
      : severity -> Int.t =
    function
    | Emergency -> 0
    | Alert -> 1
    | Critical -> 2
    | Error -> 3
    | Warning -> 4
    | Notice -> 5
    | Informational -> 6
    | Debug -> 7

  let default_sdid = "nixy@25384"

  let priority
      : facility -> severity -> String.t =
    fun facility severity ->
    (* See rfc5424 Section 6.2.1 *)
    let priority_value = ((int_of_facility facility) * 8)
                         + (int_of_severity severity) in
    Printf.sprintf "<%3d>" priority_value

  let now_as_iso8601_string
      : Unit.t -> String.t =
    fun () ->
    Time.format (Time.now ()) "%Y-%m-%dT%H:%M:%SZ"

  let tags_to_string
      : tags -> String.t =
    fun tags ->
    String.concat ~sep:" " @@
      List.map ~f:(fun (key, value) -> Printf.sprintf "%s=\"%s\"" key value) tags

  let make_tags_prefix_string
      : ?sdid:String.t -> tags -> String.t =
    fun ?sdid tags ->
    "[" ^ (Option.value ~default:default_sdid sdid) ^ " " ^ (tags_to_string tags)

  let make_header_cache
      : hostname:String.t -> app_name:String.t -> procid:String.t -> String.t =
    fun ~hostname ~app_name ~procid ->
    String.concat ~sep:" " [hostname; app_name; procid]

  let make
      : facility:facility -> hostname:String.t -> app_name:String.t
        -> ?procid:String.t -> ?tags:tags ->  ?msgid:String.t
        -> ?sdid:String.t -> severity:severity -> Unit.t -> t =
    fun ~facility ~hostname ~app_name ?procid
        ?(tags = []) ?msgid ?sdid ~severity () ->
    let realized_proc_id = Option.value
                             ~default:(Pid.to_string @@ Unix.getpid ())
                             procid in
    let build_id = Uuid.to_string @@ Uuid.create () in
    let new_tags=("buildId", build_id)::tags in
    {writer = Lazy.force Writer.stdout;
     facility; severity; build_id; hostname;
     app_name; procid = realized_proc_id; tags = new_tags;
     msgid = Option.value ~default:"-" msgid;
     sdid = Option.value ~default:default_sdid sdid;
     header_cache = make_header_cache ~hostname ~app_name ~procid:realized_proc_id;
     tag_cache = make_tags_prefix_string ?sdid new_tags}

  let set_hostname
      : t -> hostname:String.t -> t =
    fun t ~hostname ->
    let {app_name; procid} = t in
    let header_cache = make_header_cache ~hostname ~app_name ~procid in
    {t with hostname; header_cache}

  let set_sdid
      : t -> sdid:String.t -> t =
    fun t ~sdid ->
    {t with sdid; tag_cache = make_tags_prefix_string ~sdid t.tags}

  let set_msgid
      : t -> msgid:String.t -> t =
    fun t ~msgid ->
    {t with msgid}

  let add_tags
      : t -> tags:tags -> t =
    fun t ~tags ->
    let new_tags = List.append t.tags tags in
    {t with tags = new_tags; tag_cache = make_tags_prefix_string new_tags}

  let add_line_of_execution
      : t -> name:String.t -> t =
    fun t ~name ->
    let id = Uuid.to_string @@ Uuid.create () in
    add_tags t ~tags:[(name, id)]

  let make_structured_data
      : t -> tags:tags -> String.t =
    fun t ~tags ->
    t.tag_cache ^ (tags_to_string tags) ^ "]"

  let flush
      : t -> Unit.t Deferred.t =
    fun t ->
    Writer.flushed t.writer

  let raw_string
      : ?tags:(String.t * String.t) List.t ->
        ?msgid:String.t ->
        severity:severity ->
        t -> String.t -> Unit.t =
    fun ?(tags=[]) ?msgid ~severity t message ->
    if t.severity <= severity
    then let {facility; header_cache} = t in
         let structured_data = make_structured_data t ~tags in
         Writer.write t.writer
         @@ Printf.sprintf "%s1 %s %s %s %s %s\n" (priority facility severity)
                           (now_as_iso8601_string ()) header_cache
                           (Option.value ~default:t.msgid msgid)
                           structured_data message
    else ()

  let raw
      : t -> ?tags:(String.t * String.t) List.t
        -> ?msgid:String.t -> severity:severity ->
        ('a, Unit.t, String.t, Unit.t) format4 -> 'a =
    fun t ?tags ?msgid ~severity fmt ->
    Printf.ksprintf (fun msg -> raw_string t ?tags ?msgid ~severity msg) fmt

  let debug
      : t -> ?tags:(String.t * String.t) List.t
        -> ?msgid:String.t -> ('a, Unit.t, String.t, Unit.t) format4 -> 'a =
    fun t ->
    raw t  ~severity:Debug

  let info
      : t -> ?tags:(String.t * String.t) List.t
        -> ?msgid:String.t -> ('a, Unit.t, String.t, Unit.t) format4 -> 'a =
    fun t ->
    raw t ~severity:Informational

  let notice
      : t -> ?tags:(String.t * String.t) List.t
        -> ?msgid:String.t -> ('a, Unit.t, String.t, Unit.t) format4 -> 'a =
    fun t ->
    raw t ~severity:Notice

  let warning
      : t -> ?tags:(String.t * String.t) List.t
        -> ?msgid:String.t -> ('a, Unit.t, String.t, Unit.t) format4 -> 'a =
    fun t ->
    raw t ~severity:Warning

  let error
      : t -> ?tags:(String.t * String.t) List.t
        -> ?msgid:String.t -> ('a, Unit.t, String.t, Unit.t) format4 -> 'a =
    fun t ->
    raw t ~severity:Error

  let critical
      : t -> ?tags:(String.t * String.t) List.t
        -> ?msgid:String.t -> ('a, Unit.t, String.t, Unit.t) format4 -> 'a =
    fun t ->
    raw t ~severity:Critical

  let alert
      : t -> ?tags:(String.t * String.t) List.t
        -> ?msgid:String.t -> ('a, Unit.t, String.t, Unit.t) format4 -> 'a =
    fun t ->
    raw t ~severity:Alert

  let emergency
      : t -> ?tags:(String.t * String.t) List.t
        -> ?msgid:String.t -> ('a, Unit.t, String.t, Unit.t) format4 -> 'a =
    fun t ->
    raw t ~severity:Emergency
end

nixy_log.mli

open Core.Std
open Async.Std

(* This module produces log output that complies with
   [rfc5424](http://tools.ietf.org/html/rfc5424) *)

module type S =
sig
  type t

  type tags = (String.t * String.t) List.t

  type severity =
    | Emergency
    | Alert
    | Critical
    | Error
    | Warning
    | Notice
    | Informational
    | Debug

  val set_msgid: t -> msgid:String.t -> t
  val add_tags: t -> tags:tags -> t
  val flush: t -> Unit.t Deferred.t
  val debug: t -> ?tags:(String.t * String.t) List.t -> ?msgid:String.t
    -> ('a, Unit.t, String.t, Unit.t) format4 -> 'a

  val info: t -> ?tags:(String.t * String.t) List.t
    -> ?msgid:String.t -> ('a, Unit.t, String.t, Unit.t) format4 -> 'a
  val notice: t -> ?tags:(String.t * String.t) List.t
    -> ?msgid:String.t -> ('a, Unit.t, String.t, Unit.t) format4 -> 'a
  val warning: t -> ?tags:(String.t * String.t) List.t
    -> ?msgid:String.t -> ('a, Unit.t, String.t, Unit.t) format4 -> 'a
  val error: t -> ?tags:(String.t * String.t) List.t
    -> ?msgid:String.t -> ('a, Unit.t, String.t, Unit.t) format4 -> 'a
  val critical: t -> ?tags:(String.t * String.t) List.t
    -> ?msgid:String.t -> ('a, Unit.t, String.t, Unit.t) format4 -> 'a
  val alert: t -> ?tags:(String.t * String.t) List.t
    -> ?msgid:String.t -> ('a, Unit.t, String.t, Unit.t) format4 -> 'a
  val emergency:  t -> ?tags:(String.t * String.t) List.t
    -> ?msgid:String.t -> ('a, Unit.t, String.t, Unit.t) format4 -> 'a

end

module type Syslog_intf =
sig
  include S

  type facility =
    | Kernel_messages
    | User_level_messages
    | Mail_system
    | System_daemons
    | Security_authorization_messages_1
    | Messages_generated_internally_by_syslogd
    | Line_printer_subsystem
    | Network_news_subsystem
    | UUCP_subsystem
    | Clock_daemon_1
    | Security_authorization_messages_2
    | FTP_daemon
    | NTP_subsystem
    | Log_audit
    | Log_alert
    | Clock_daemon_2
    | Local_use_0
    | Local_use_1
    | Local_use_2
    | Local_use_3
    | Local_use_4
    | Local_use_5
    | Local_use_6
    | Local_use_7

  val make : facility:facility -> hostname:String.t -> app_name:String.t
    -> ?procid:String.t -> ?tags:tags ->  ?msgid:String.t
    -> ?sdid:String.t -> severity:severity -> Unit.t -> t

  val set_hostname: t -> hostname:String.t -> t
end

module Syslog : Syslog_intf

module Make(Impl : S) : S with type t = Impl.t